How do you speed up VBA code with named range?

Question

I wrote a program that analyzes a worksheet (with 8000 rows and 40 columns) and returns all the corresponding product identifiers, but my program is unbearably slow, it takes about 5 minutes to execute, so looking for a way to speed it up, I came across some code, To disable screen shielding, display the status bar, calculation, and events. which doubled the execution time of programs (from 5 to 10 minutes). But I need the program to work faster. I continued to search and stumbled upon This. It seems to me that this is exactly what I need, but I do not quite understand how to implement it.

Let me explain what my code should do, and maybe you can help me find a better way. It may be useful for you to tell you what this is about. I work for a company that sells holsters, and we are trying to find a way to put the entire product identifier for different types of holsters for 1 gun together. So, in the first column we have the names Gun, in the 4th column we have the type of holster, and in the 12th column we have the product identifier.

What I'm trying to do is for any given line so that the program looks at the rest of the file and returns the product identifier for the corresponding products (products with the same name) in lines 33-39, i.e. column 33 will have an accompanying concealment holster, 34 will have an appropriate ankle holster, etc.

I already wrote the code for this, but how can I do this with this DataRange method?

Do
    ActiveCell.Offset(1, 0).Activate
    Location = ActiveCell.Address
    GunName = ActiveCell.Value
    X = 0
    Range("A1").Activate

    Do
        If ActiveCell.Offset(X, 0).Value = GunName Then
        PlaceHolder = ActiveCell.Address
            If ActiveCell.Offset(X, 3).Value = "CA" Then
                Range(Location).Offset(0, 34).Value = ActiveCell.Offset(X, 12).Value
            ElseIf ActiveCell.Offset(X, 3).Value = "AA" Or ActiveCell.Offset(X, 3).Value = "AR" Then
                If ActiveCell.Offset(X, 4).Value = "NA-LH" Or ActiveCell.Offset(X, 4).Value = "NA" Or ActiveCell.Offset(X, 4).Value = "11-LH" Or ActiveCell.Offset(X, 4).Value = "13-LH" Or ActiveCell.Offset(X, 4).Value = "12-A-LH" Or ActiveCell.Offset(X, 4).Value = "12-B-LH" Or ActiveCell.Offset(X, 4).Value = "12-C-LH" Or ActiveCell.Offset(X, 4).Value = "12-JB-LH" Or ActiveCell.Offset(X, 4).Value = "12-LS-LH" Or ActiveCell.Offset(X, 4).Value = "12-LS-b-LH" Or ActiveCell.Offset(X, 4).Value = "11-LS-LH" Or ActiveCell.Offset(X, 4).Value = "21L" Then

                Else
                    Range(Location).Offset(0, 35).Value = ActiveCell.Offset(X, 12)
            End If
            ElseIf ActiveCell.Offset(X, 3).Value = "BA" Or ActiveCell.Offset(X, 3).Value = "BR" Then
                Range(Location).Offset(0, 36).Value = ActiveCell.Offset(X, 12)
            ElseIf ActiveCell.Offset(X, 3).Value = "HA" Or ActiveCell.Offset(X, 3).Value = "HR" Then
                Range(Location).Offset(0, 37).Value = ActiveCell.Offset(X, 12)
            ElseIf ActiveCell.Offset(X, 3).Value = "VA" Or ActiveCell.Offset(X, 3).Value = "VR" Then
                Range(Location).Offset(0, 38).Value = ActiveCell.Offset(X, 12)
            ElseIf ActiveCell.Offset(X, 3).Value = "TA" Or ActiveCell.Offset(X, 3).Value = "TR" Then
                Range(Location).Offset(0, 39).Value = ActiveCell.Offset(X, 12)
            End If
        End If
        X = X + 1
    Loop Until IsEmpty(ActiveCell.Offset(X, 0).Value)
    ActiveCell.Range(Location).Activate
Loop Until IsEmpty(ActiveCell.Value)

AA, BA CA, etc. - types of holsters.

Answer 1

EDIT

After viewing the sample file and clarifying using the comments below, here is the updated code. I believe this should work for you:

Sub tgr()

    Dim rngData As Range
    Dim GunCell As Range
    Dim rngFound As Range
    Dim arrResults() As Variant
    Dim ResultIndex As Long
    Dim cIndex As Long
    Dim strFirst As String
    Dim strTemp As String

    On Error Resume Next
    With Range("DataRange")
        .Sort .Resize(, 1), xlAscending, Header:=xlYes
        Set rngData = .Resize(, 1)
    End With
    On Error GoTo 0
    If rngData Is Nothing Then Exit Sub   'No data or no named range "DataRange"

    With rngData
        ReDim arrResults(1 To .Rows.Count, 1 To 6)
        For Each GunCell In .Cells
            If GunCell.Row > 1 Then
                ResultIndex = ResultIndex + 1
                If LCase(GunCell.Text) <> strTemp Then
                    strTemp = LCase(GunCell.Text)
                    Set rngFound = .Find(strTemp, .Cells(.Cells.Count), xlValues, xlWhole)
                    If Not rngFound Is Nothing Then
                        strFirst = rngFound.Address
                        Do
                            If InStr(1, " CA BA HA VA TA ", " " & .Parent.Cells(rngFound.Row, "D").Text & " ", vbTextCompare) > 0 Then
                                Select Case UCase(.Parent.Cells(rngFound.Row, "D").Text)
                                    Case "CA":  cIndex = 1
                                    Case "BA":  cIndex = 3
                                    Case "HA":  cIndex = 4
                                    Case "VA":  cIndex = 5
                                    Case "TA":  cIndex = 6
                                End Select
                                arrResults(ResultIndex, cIndex) = .Parent.Cells(rngFound.Row, "M").Text
                            ElseIf InStr(1, " AA AR ", " " & .Parent.Cells(rngFound.Row, "D").Text & " ", vbTextCompare) > 0 _
                            And InStr(1, " NA-LH NA 11-LH 13-LH 12-A-LH 12-B-LH 12-C-LH 12-JB-LH 12-LS-LH 12-LS-b-LH 11-LS-LH 21L ", " " & .Parent.Cells(rngFound.Row, "E").Text & " ", vbTextCompare) = 0 Then
                                cIndex = 2
                                arrResults(ResultIndex, cIndex) = .Parent.Cells(rngFound.Row, "M").Text
                            End If
                            Set rngFound = .Find(strTemp, rngFound, xlValues, xlWhole)
                        Loop While rngFound.Address <> strFirst
                    End If
                Else
                    For cIndex = 1 To UBound(arrResults, 2)
                        arrResults(ResultIndex, cIndex) = arrResults(ResultIndex - 1, cIndex)
                    Next cIndex
                End If
            End If
        Next GunCell
    End With

    Range("AI2:AI" & Rows.Count).Resize(, UBound(arrResults, 2)).ClearContents
    If ResultIndex > 0 Then Range("AI2").Resize(ResultIndex, UBound(arrResults, 2)).Value = arrResults

End Sub

Answer 2

Avoid .Activatethat is VERY slow and usually useless. Instead, try something in this style:

Option Explicit

Sub sample()
    Dim c As Range

    For Each c In Range("a:a").SpecialCells(xlCellTypeConstants)
        If c.Offset(x, 0).Value = GunName Then
            'etc etc
        End If
    Next c

End Sub

ABOUT! and make sure that you are using Option Explicitand you Dimare your variables. This is not for speed, it is to avoid mistakes. And use the comments ;-)