How do you speed up VBA code with a named range? - vba

Question

I have written a program that analyzes a worksheet (with 8000 rows and 40 columns) and returns all of the relevant product ID's but my program is unbearably slow, it takes about 5 minutes to run, so In looking for a way to speed it up I came across some code to disable screenupdating, display status bar, calculation, and events. which doubled the programs run time (from 5 to 10 minutes) But i need the program to be able to run faster still. I kept searching and came across This This seems like it's exactly what i need but i don't exactly understand how to implement it.
Let me explain what my code needs to do and maybe you can help me find a better way. It might be helpful to tell you what the information is about. I work for a company that sells holsters, and we are trying to find a way to gather all of the product ID's for different types of holsters for 1 gun together. So in the first column we have the Gun names, in the 4th column we have the Holster Type and in the 12th column we have the Product ID #.
What I'm trying to do is to for any given line, make the program look throught the rest of the file and return the product ID's for the matching products (products with the exact same name) in lines 33-39 i.e column 33 will have the related concealment holster, 34 will have the related ankle holster etc.
I have already written a code to do this but how can i do it with this named 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 are the holster types.

Answer 1

EDIT
After viewing the sample file and clarifying through the below comments, 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 .Activate, which is VERY slow and generally 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
Oh ! and make sure you use Option Explicit and you Dim your variables. It's not for speed, it is to avoid errors. And use comments ;-)