Sub takes 10 minutes to run and sometimes crashes, need help streamlining it

Question

I have a code that sorts 100K+ of inventory on to 9 sheets in a workbook. The code has some bugs but overall works fine. The issue is that it takes around 10 minutes to run and depending on the computer overloads the buffer and crashes excel. I have rewritten it a couple time and I am now asking for help in streamlining it. The code is below, any suggestions are greatly appreciated. The code takes one sheet with 100K+ lines of inventory, finds it's location on the appropriate sheet and tallies the numbers. There are 9 sheets with 3 different formats.

Sub SortTMS()

Application.ScreenUpdating = False
Application.Calculation = xlManual

Dim LDate As Date
Dim Slot As String
Dim SlotRange As Range
Dim SlotAddress1 As Range
Dim SlotAddress2 As Range
Dim SlotLookUp1 As Range
Dim SlotLookUp2 As Range

Dim SR1 As String, SR2 As String, SR3 As String, SR4 As String, SR5 As String
Dim SR6 As String, SR7 As String, SR8 As String, SR9 As String, SR10 As String
Dim SR11 As String, SR12 As String, SR13 As String, SR14 As String, SR15 As String
Dim SR16 As String, SR17 As String, SR18 As String, SR19 As String, SR20 As String
Dim SR21 As String

Dim SlotWs1 As Worksheet, SlotWs2 As Worksheet, SlotWs3 As Worksheet, SlotWs4 As Worksheet
Dim SlotWs5 As Worksheet, SlotWs6 As Worksheet, SlotWs7 As Worksheet, TMSWs As Worksheet

Set SlotWs1 = ThisWorkbook.Worksheets("A Mod")
Set SlotWs2 = ThisWorkbook.Worksheets("B Mod")
Set SlotWs3 = ThisWorkbook.Worksheets("C Mod")
Set SlotWs4 = ThisWorkbook.Worksheets("D Mod")
Set SlotWs5 = ThisWorkbook.Worksheets("E Mod")
Set SlotWs6 = ThisWorkbook.Worksheets("F Mod")
Set SlotWs7 = ThisWorkbook.Worksheets("Offline")
Set SlotWs8 = ThisWorkbook.Worksheets("DPAL")
Set SlotWs9 = ThisWorkbook.Worksheets("NC DPAL")
Set TMSWs = ThisWorkbook.Sheets("TMS Data")

SR1 = "A5:A3100"            ''      1st high                alpha high dpal                 offline A3500
SR2 = "E5:E3100"            ''                              alpha low dpal
SR3 = "G5:G3100"            ''      1st low                                                 offline A3900
SR4 = "J5:J3100"            ''                              bravo high dpal
SR5 = "M5:M3100"            ''      2nd high                                                offline B3100
SR6 = "N5:N3100"            ''                              bravo low dpal
SR7 = "S5:S3100"            ''      2nd low                 charlie high dpal               Aerosol Q0001
SR8 = "W5:W3100"            ''                              charlie low dpal
SR9 = "Y5:Y3100"            ''      3rd high
SR10 = "AB5:AB3100"         ''                              delta high dpal
SR11 = "AE5:AE3100"         ''      3rd low
SR12 = "AF5:AF3100"         ''                              delta low dpal
SR13 = "AK5:AK3100"         ''      1st high non com        echo high dpal
SR14 = "AO5:AO3100"         ''                              echo low dpal
SR15 = "AQ5:AQ3100"         ''      1st low non com
SR16 = "AT5:AT3100"         ''                              fox high dpal
SR17 = "AW5:AW3100"         ''      2nd high non com
SR18 = "AX5:AX3100"         ''                              fox high dpal
SR19 = "BC5:BC3100"         ''      2nd low non com
SR20 = "BI5:BI3100"         ''      3rd high non com
SR21 = "BO5:BO3100"         ''      3rd low non com

SlotWs1.Range("aclear").ClearContents
SlotWs2.Range("bclear").ClearContents
SlotWs3.Range("cclear").ClearContents
SlotWs4.Range("dclear").ClearContents
SlotWs5.Range("eclear").ClearContents
SlotWs6.Range("fclear").ClearContents
SlotWs7.Range("offclear").ClearContents
SlotWs7.Range("DPALclear").ClearContents
SlotWs7.Range("NCDPALClear").ClearContents
        

Set SlotRange = TMSWs.Range("I:I")
        
    For Each cl In SlotRange
     
On Error GoTo ErrHandler
    
        Slot = cl.Value
        LDate = TMSWs.Range(cl.Address).Offset(0, -5).Value
        
        Select Case Slot
            Case "A0001" To "A0010"                                 'Alpha 1st low non com
                Set SlotLookUp1 = SlotWs1.Range(SR15)
            Case "A0011" To "A0499"                                 'Alpha 1st low
                Set SlotLookUp1 = SlotWs1.Range(SR3)
            Case "A0500" To "A0633"                                 'Alpha 1st high
                Set SlotLookUp1 = SlotWs1.Range(SR1)
            Case "A0634" To "A0999"                                 'Alpha 1st high non com
                Set SlotLookUp1 = SlotWs1.Range(SR13)
            Case "A1001" To "A1012"                                 'Alpha 2nd low non com
                Set SlotLookUp1 = SlotWs1.Range(SR19)
            Case "A1013" To "A1499"                                 'Alpha 2nd low
                Set SlotLookUp1 = SlotWs1.Range(SR7)
            Case "A1500" To "A1752"                                 'Alpha 2nd high
                Set SlotLookUp1 = SlotWs1.Range(SR5)
            Case "A1753" To "A1999"                                 'Alpha 2nd high non com
                Set SlotLookUp1 = SlotWs1.Range(SR17)
            Case "A2001" To "A2020"                                 'Alpha 3rd low non com
                Set SlotLookUp1 = SlotWs1.Range(SR21)
            Case "A2021" To "A2499"                                 'Alpha 3rd low
                Set SlotLookUp1 = SlotWs1.Range(SR11)
            Case "A2500" To "A2745"                                 'Alpha 3rd high
                Set SlotLookUp1 = SlotWs1.Range(SR9)
            Case "A2746" To "A2999"                                 'Alpha 3rd high non com
                Set SlotLookUp1 = SlotWs1.Range(SR20)
                
            Case "B0001" To "B0010"                                 'Bravo 1st low non com
                Set SlotLookUp1 = SlotWs2.Range(SR15)
            Case "B0011" To "B0499"                                 'Bravo 1st low
                Set SlotLookUp1 = SlotWs2.Range(SR3)
            Case "B0500" To "B0632"                                 'Bravo 1st high
                Set SlotLookUp1 = SlotWs2.Range(SR1)
            Case "B0633" To "B0999"                                 'Bravo 1st high non com
                Set SlotLookUp1 = SlotWs2.Range(SR13)
            Case "B1000" To "B1012"                                 'Bravo 2nd low non com
                Set SlotLookUp1 = SlotWs2.Range(SR19)
            Case "B1013" To "B1499"                                 'Bravo 2nd low
                Set SlotLookUp1 = SlotWs2.Range(SR7)
            Case "B1500" To "B1760"                                 'Bravo 2nd high
                Set SlotLookUp1 = SlotWs2.Range(SR5)
            Case "B1761" To "B1999"                                 'Bravo 2nd high non com
                Set SlotLookUp1 = SlotWs2.Range(SR17)
            Case "B2000" To "B2020"                                 'Bravo 3rd low non com
                Set SlotLookUp1 = SlotWs2.Range(SR21)
            Case "B2021" To "B2499"                                 'Bravo 3rd low
                Set SlotLookUp1 = SlotWs2.Range(SR11)
            Case "B2500" To "B2753"                                 'Bravo 3rd high
                Set SlotLookUp1 = SlotWs2.Range(SR9)
            Case "B2754" To "B2999"                                 'Bravo 3rd high non com
                Set SlotLookUp1 = SlotWs2.Range(SR20)
                
            Case "C0001" To "C0012"                                 'Charlie 1st low non com
                Set SlotLookUp1 = SlotWs3.Range(SR15)
            Case "C0013" To "C0499"                                 'Charlie 1st low
                Set SlotLookUp1 = SlotWs3.Range(SR3)
            Case "C0500" To "C0635"                                 'Charlie 1st high
                Set SlotLookUp1 = SlotWs3.Range(SR1)
            Case "C0636" To "C0999"                                 'Charlie 1st high non com
                Set SlotLookUp1 = SlotWs3.Range(SR13)
            Case "C1000" To "C1016"                                 'Charlie 2nd low non com
                Set SlotLookUp1 = SlotWs3.Range(SR19)
            Case "C1017" To "C1499"                                 'Charlie 2nd low
                Set SlotLookUp1 = SlotWs3.Range(SR7)
            Case "C1500" To "C1748"                                 'Charlie 2nd high
                Set SlotLookUp1 = SlotWs3.Range(SR5)
            Case "C1749" To "C1999"                                 'Charlie 2nd high non com
                Set SlotLookUp1 = SlotWs3.Range(SR17)
            Case "C2000" To "C2024"                                 'Charlie 3rd low non com
                Set SlotLookUp1 = SlotWs3.Range(SR21)
            Case "C2025" To "C2499"                                 'Charlie 3rd low
                Set SlotLookUp1 = SlotWs3.Range(SR11)
            Case "C2500" To "C2749"                                 'Charlie 3rd high
                Set SlotLookUp1 = SlotWs3.Range(SR9)
            Case "C2750" To "C2999"                                 'Charlie 3rd high non com
                Set SlotLookUp1 = SlotWs3.Range(SR20)
                
            Case "D0001" To "D0009"                                 'Delta 1st low non com
                Set SlotLookUp1 = SlotWs4.Range(SR15)
            Case "D0010" To "D0499"                                 'Delta 1st low
                Set SlotLookUp1 = SlotWs4.Range(SR3)
            Case "D0500" To "D0634"                                 'Delta 1st high
                Set SlotLookUp1 = SlotWs4.Range(SR1)
            Case "D0635" To "D0999"                                 'Delta 1st high non com
                Set SlotLookUp1 = SlotWs4.Range(SR13)
            Case "D1000" To "D1014"                                 'Delta 2nd low non com
                Set SlotLookUp1 = SlotWs4.Range(SR19)
            Case "D1015" To "D1499"                                 'Delta 2nd low
                Set SlotLookUp1 = SlotWs4.Range(SR7)
            Case "D1500" To "D1753"                                 'Delta 2nd high
                Set SlotLookUp1 = SlotWs4.Range(SR5)
            Case "D1754" To "D1999"                                 'Delta 2nd high non com
                Set SlotLookUp1 = SlotWs4.Range(SR17)
            Case "D2000" To "D2020"                                 'Delta 3rd low non com
                Set SlotLookUp1 = SlotWs4.Range(SR21)
            Case "D2021" To "D2499"                                 'Delta 3rd low
                Set SlotLookUp1 = SlotWs4.Range(SR11)
            Case "D2500" To "D2750"                                 'Delta 3rd high
                Set SlotLookUp1 = SlotWs4.Range(SR9)
            Case "D2751" To "D2999"                                 'Delta 3rd high non com
                Set SlotLookUp1 = SlotWs4.Range(SR20)
                
            Case "E0001" To "E0010"                                 'Echo 1st low non com
                Set SlotLookUp1 = SlotWs5.Range(SR15)
            Case "E0011" To "E0499"                                 'Echo 1st low
                Set SlotLookUp1 = SlotWs5.Range(SR3)
            Case "E0500" To "E0638"                                 'Echo 1st high
                Set SlotLookUp1 = SlotWs5.Range(SR1)
            Case "E0639" To "E0999"                                 'Echo 1st high non com
                Set SlotLookUp1 = SlotWs5.Range(SR13)
            Case "E1000" To "E1019"                                 'Echo 2nd low non com
                Set SlotLookUp1 = SlotWs5.Range(SR19)
            Case "E1020" To "E1499"                                 'Echo 2nd low
                Set SlotLookUp1 = SlotWs5.Range(SR7)
            Case "E1500" To "E1760"                                 'Echo 2nd high
                Set SlotLookUp1 = SlotWs5.Range(SR5)
            Case "E1761" To "E1999"                                 'Echo 2nd high non com
                Set SlotLookUp1 = SlotWs5.Range(SR17)
            Case "E2000" To "E2020"                                 'Echo 3rd low non com
                Set SlotLookUp1 = SlotWs5.Range(SR21)
            Case "E2021" To "E2499"                                 'Echo 3rd low
                Set SlotLookUp1 = SlotWs5.Range(SR11)
            Case "E2500" To "E2758"                                 'Echo 3rd high
                Set SlotLookUp1 = SlotWs5.Range(SR9)
            Case "E2759" To "E2999"                                 'Echo 3rd high non com
                Set SlotLookUp1 = SlotWs5.Range(SR20)
                
            Case "F0001" To "F0053"                                 'Fox 1st low non com
                Set SlotLookUp1 = SlotWs6.Range(SR15)
            Case "F0054" To "F0499"                                 'Fox 1st low
                Set SlotLookUp1 = SlotWs6.Range(SR3)
            Case "F0500" To "F0636"                                 'Fox 1st high
                Set SlotLookUp1 = SlotWs6.Range(SR1)
            Case "F0637" To "F0999"                                 'Fox 1st high non com
                Set SlotLookUp1 = SlotWs6.Range(SR13)
            Case "F1000" To "F1106"                                 'Fox 2nd low non com
                Set SlotLookUp1 = SlotWs6.Range(SR19)
            Case "F1107" To "F1499"                                 'Fox 2nd low
                Set SlotLookUp1 = SlotWs6.Range(SR7)
            Case "F1500" To "F1757"                                 'Fox 2nd high
                Set SlotLookUp1 = SlotWs6.Range(SR5)
            Case "F1758" To "F1999"                                 'Fox 2nd high non com
                Set SlotLookUp1 = SlotWs6.Range(SR17)
            Case "F2000" To "F2018"                                 'Fox 3rd low non com
                Set SlotLookUp1 = SlotWs6.Range(SR21)
            Case "F2019" To "F2499"                                 'Fox 3rd low
                Set SlotLookUp1 = SlotWs6.Range(SR11)
            Case "F2500" To "F2749"                                 'Fox 3rd high
                Set SlotLookUp1 = SlotWs6.Range(SR9)
            Case "F2750" To "F2999"                                 'Fox 3rd high non com
                Set SlotLookUp1 = SlotWs6.Range(SR20)
                
            Case "A3500" To "A3899"                                 'Offline A3500
                Set SlotLookUp1 = SlotWs7.Range(SR1)
            Case "A3900" To "A3999"                                 'Offline A3900
                Set SlotLookUp1 = SlotWs7.Range(SR3)
            Case "B3100" To "B3499"                                 'Offline A3100
                Set SlotLookUp1 = SlotWs7.Range(SR5)
            Case "Q0001" To "Q2999"                                 'Aerosol
                Set SlotLookUp1 = SlotWs7.Range(SR7)
                
            Case "A8000" To "A9999", "I4000" To "I5999", "J4000" To "J4999", "X4000" To "X6999"             'alpha high dpal
                Set SlotLookUp1 = Union(SlotWs8.Range(SR1), SlotWs9.Range(SR1))
            Case "A4000" To "A7999"                                                                         'alpha low dpal
                Set SlotLookUp1 = Union(SlotWs8.Range(SR1), SlotWs9.Range(SR1))
            Case "C4000" To "C6999"                                                                         'bravo high dpal
                Set SlotLookUp1 = Union(SlotWs8.Range(SR1), SlotWs9.Range(SR1))
            Case "B4000" To "B9999", "J6000" To "J9999", "L4000" To "L7999"                                 'bravo low dpal
                Set SlotLookUp1 = Union(SlotWs8.Range(SR1), SlotWs9.Range(SR1))
            Case "D4000" To "D6999"                                                                         'charlie high dpal
                Set SlotLookUp1 = Union(SlotWs8.Range(SR1), SlotWs9.Range(SR1))
            Case "C7000" To "C9999"                                                                         'charkie low dpal
                Set SlotLookUp1 = Union(SlotWs8.Range(SR1), SlotWs9.Range(SR1))
            Case "E4000" To "E6999"                                                                         'delta high dpal
                Set SlotLookUp1 = Union(SlotWs8.Range(SR1), SlotWs9.Range(SR1))
            Case "D7000" To "D9999"                                                                         'delta low dpal
                Set SlotLookUp1 = Union(SlotWs8.Range(SR1), SlotWs9.Range(SR1))
            Case "F4000" To "F6999"                                                                         'echo high dpal
                Set SlotLookUp1 = Union(SlotWs8.Range(SR1), SlotWs9.Range(SR1))
            Case "E7000" To "E9999"                                                                         'echo low dpal
                Set SlotLookUp1 = Union(SlotWs8.Range(SR1), SlotWs9.Range(SR1))
            Case "G4000" To "G6999", "Q4000" To "Q7999", "T4000" To "T9999", "W4000" To "W8999"             'fox high dpal
                Set SlotLookUp1 = Union(SlotWs8.Range(SR1), SlotWs9.Range(SR1))
            Case "F7000" To "F9999"                                                                         'fox low dpal
                Set SlotLookUp1 = Union(SlotWs8.Range(SR1), SlotWs9.Range(SR1))
                
            Case Else
                Debug.Print Slot
                Slot = ""
            End Select
            
                If Slot = "" Then
                Else
                    If LDate >= Date Then
                    
                        With SlotLookUp1
                            Set SlotAddress1 = .Find(What:=Slot, After:=.Cells(.Cells.Count), LookIn:=xlValues, _
                                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Offset(0, 1)
                            Set SlotAddress2 = .Find(What:=Slot, After:=.Cells(.Cells.Count), LookIn:=xlValues, _
                                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Offset(0, 2)
                        End With
                        
                        SlotAddress1.Value = SlotAddress1.Value + 1
                        SlotAddress2.Value = SlotAddress2.Value + 1
                        
                    ElseIf LDate < Date Then
                    
                        With SlotLookUp1
                            Set SlotAddress1 = .Find(What:=Slot, After:=.Cells(.Cells.Count), LookIn:=xlValues, _
                                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Offset(0, 1)
                            Set SlotAddress2 = .Find(What:=Slot, After:=.Cells(.Cells.Count), LookIn:=xlValues, _
                                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Offset(0, 3)
                        End With
                        
                        SlotAddress1.Value = SlotAddress1.Value + 1
                        SlotAddress2.Value = SlotAddress2.Value + 1
                        
                    End If
                End If
                
ErrHandler:
    Debug.Print Slot
    Resume Next
    
        Next cl

Application.ScreenUpdating = True
Application.Calculation = xlAutomatic

End Sub

Do you need the 2nd find? can this just be `SlotAddress2=SlotAddress1.offset(0,2)` ? — Nathan_Sav, Mar 24 '22 at 17:11
That huge `Select Case` and associated variables would likely be much better as a lookup table on a worksheet. Easier to review and maintain... — Tim Williams, Mar 24 '22 at 17:25
I tried your suggestion Nathen and it only made a minuet difference. Everything helps though, thank you. — Hareborn, Mar 24 '22 at 17:26
I have to agree the the huge select case plays a major part but with 100K+ items going to over 14K locations I couldn't think of anything better. I tried to use match first but could not get the syntax to work as a single item. With the match I had 4 different one to locate the same info I achieved with one find. If you can help I would greatly appreciate it. — Hareborn, Mar 24 '22 at 17:32
If you want to speed up things you will have to redesign the data structure and or re-think the approach. Rather work in RAM than in Excel objects. Example you can read data quickly into memory using arrays I would also consider other data structures / methods like Dictionaries. — MrT, Mar 24 '22 at 18:03
`Set SlotLookUp1 = Union(SlotWs8.Range(SR1), SlotWs9.Range(SR1))` FYI you cannot `Union` ranges from different sheets. — Tim Williams, Mar 24 '22 at 18:25
A quick win would be an alteration: `Set SlotRange = Application.Intersect(TMSWs.UsedRange, TMSWs.Range("I:I"))` — Tragamor, Mar 24 '22 at 18:54

score 1 · Answer 1 · answered Mar 24 '22 at 18:00

Consider https://stackoverflow.com/questions/33302962/performance-difference-between-looping-range-vs-looping-array#:~:text=Looping%20through%20an%20array%20is%20way%20faster%20than%20looking%20through%20a%20range.&text=Which%20makes%20looping%20through%20an,faster%20than%20through%20a%20loop.&text=The%20more%20values%20you%20have%2C%20the%20bigger%20the%20difference%20will%20be.

TLDR: instead of directly updating and pulling from cells, assign your Range to a 2d array first. In my own sheets this has improved performance by 30 times. Perform all calculations and assignments on the array, then assign the array back to your Range.

Tim Williams · Accepted Answer · 2022-03-25T17:15:18.637

1

200,000 Find() calls are going to be super-slow: using Match would be much faster.

Eg:

Dim oSet As Long, m, Slot, SlotLookup1, LDate
'...
'...
'...
If Len(Slot) > 0 Then
    m = Application.Match(Slot, SlotLookup1, 0) 'faster than `Find()`
    If Not IsError(m) Then                      'got a match?
        oSet = IIf(LDate >= Date, 2, 3)         'offset for second cell to be incremented
        With SlotLookup1.Cells(m)
            .Offset(0, 1).Value = .Offset(0, 1).Value + 1       'increment cell values
            .Offset(0, oSet).Value = .Offset(0, oSet).Value + 1
        End With
    End If
End If
'...
'...
'...

Also consider @Tragamor's advice about not looping over all rows of column I, which is about 10x your actual # of rows of data

edited Mar 25 '22 at 17:15

answered Mar 25 '22 at 01:58

Tim Williams

154,628
8
97
125

Thank you Tim, I used your code and it dropped run time from around 10 minutes to 202.601562 seconds. That's a increase of over 400% on run speed. I am also currently working on @Tragamor's advice of loading everything into a array and sorting it from there. – Hareborn Mar 25 '22 at 13:56
I have to thank you again Tim. Your comment about not being able to use unions got me looking and I was getting 1.2 million errors, 12 per x 100,000 iterations. After clearing the unions and also throwing in a "counta" to limit the sorting to only the labels not the infinite sheet my timing is down to 15.99 seconds. I haven't switched to a array yet but probably don't need to now. – Hareborn Mar 25 '22 at 16:57
An array might not help that much in this case - you still need to do the cell-by-cell +1 on many different ranges, and organizing those into arrays might be pretty complex. In my testing, reading the values from a whole column cell-by-cell only took a few seconds, so that's likely not a bottleneck for you. – Tim Williams Mar 25 '22 at 17:08
Thank you Tim, you helped me allot! My new code is below. – Hareborn Apr 02 '22 at 01:04

Hareborn · Answer 3 · 2022-04-02T01:02:27.977

Have to give a shout out to Tim Williams , your advice was extremely helpful. My sub in now down to around 20 seconds which is amazing. I even instituted the changes to another sub and dropped in time for 3 minutes to 5 seconds, again thank you for the help. Here is the final code, maybe it can help someone else. It sorts 100K+ items across 9 sheets with 3 different formats in 25 seconds.

Sub SortTMS()
    
Application.ScreenUpdating = False
Application.Calculation = xlManual

Dim oSet As Long, m, Slot, SlotLookup1, LDate

    Dim lStart As Double
    Dim lEnd As Double

    lStart = Timer

Dim SlotRange As Range
Dim SlotAddress1 As Range
Dim SlotAddress2 As Range
Dim x As Long
Dim y As Long
Dim z As Long

Dim Answer As Long

Answer = MsgBox("Notice:" & _
                vbCrLf & _
                vbCrLf & "If this is the first time TMS Data is uploaded today all initial numbers will alse be reset along with current totals" & _
                vbCrLf & _
                vbCrLf & "If this is not the first upload of the day all initial numbers will remain the same and only the current totals will be updated" & _
                vbCrLf & _
                vbCrLf & _
                "Select ""YES"" to also reset the initial numbers for today" & _
                vbCrLf & "Select ""NO"" to load only current totals" & _
                vbCrLf & "Select ""Cancel"" to exit without changing any numbers", vbDefaultButton2 Or vbYesNoCancel, "TMS Data Download")

If Answer = 2 Then
    Exit Sub
End If

Dim SR1 As String, SR2 As String, SR3 As String, SR4 As String, SR5 As String
Dim SR6 As String, SR7 As String, SR8 As String, SR9 As String, SR10 As String
Dim SR11 As String, SR12 As String, SR13 As String, SR14 As String, SR15 As String
Dim SR16 As String, SR17 As String, SR18 As String, SR19 As String, SR20 As String
Dim SR21 As String, SR22 As String, SR23 As String, SR24 As String

Dim SlotWs1 As Worksheet, SlotWs2 As Worksheet, SlotWs3 As Worksheet, SlotWs4 As Worksheet
Dim SlotWs5 As Worksheet, SlotWs6 As Worksheet, SlotWs7 As Worksheet, TMSWs As Worksheet

Set SlotWs1 = ThisWorkbook.Worksheets("A Mod")
Set SlotWs2 = ThisWorkbook.Worksheets("B Mod")
Set SlotWs3 = ThisWorkbook.Worksheets("C Mod")
Set SlotWs4 = ThisWorkbook.Worksheets("D Mod")
Set SlotWs5 = ThisWorkbook.Worksheets("E Mod")
Set SlotWs6 = ThisWorkbook.Worksheets("F Mod")
Set SlotWs7 = ThisWorkbook.Worksheets("Offline")
Set SlotWs8 = ThisWorkbook.Worksheets("DPAL")
Set SlotWs9 = ThisWorkbook.Worksheets("NC DPAL")
Set TMSWs = ThisWorkbook.Sheets("TMS Data")

SR1 = "A5:A3100"            
SR2 = "F5:F3100"            
SR3 = "G5:G3100"            
SR4 = "L5:L3100"            
SR5 = "M5:M3100"            
SR6 = "Q5:Q3100"           
SR7 = "S5:S3100"            
SR8 = "W5:W3100"            
SR9 = "Y5:Y3100"            
SR10 = "AA5:AA3100"         
SR11 = "AB5:AB3100"         
SR12 = "AE5:AE3100"         
SR13 = "AG5:AG3100"         
SR14 = "AH5:AH3100"         
SR15 = "AK5:AK3100"         
SR16 = "AM5:AM3100"         
SR17 = "AQ5:AQ3100"        
SR18 = "AS5:AS3100"         
SR19 = "AW5:AW3100"         
SR20 = "AX5:AX3100"         
SR21 = "BC5:BC3100"         
SR22 = "BD5:BD3100"         
SR23 = "BI5:BI3100"        
SR24 = "BO5:BO3100"        

SlotWs1.Range("aclear").ClearContents
SlotWs2.Range("bclear").ClearContents
SlotWs3.Range("cclear").ClearContents
SlotWs4.Range("dclear").ClearContents
SlotWs5.Range("eclear").ClearContents
SlotWs6.Range("fclear").ClearContents
SlotWs7.Range("offlineclear").ClearContents
SlotWs8.Range("DPALClear2").ClearContents
SlotWs9.Range("NCDPALClear2").ClearContents

x = 3
y = Application.WorksheetFunction.CountA(TMSWs.Range("I:I"))
z = 0

Set SlotRange = TMSWs.Range("I1:I" & y)

    For Each cl In SlotRange

On Error GoTo ErrHandler

        Slot = cl.Value
        LDate = TMSWs.Range(cl.Address).Offset(0, -5).Value
        
        If Slot = "X6876" Then
            lEnd = Timer
            Debug.Print "Duration = " & (lEnd - lStart) & " seconds - Last label"
        End If
        
        Select Case Slot
            Case "A0001" To "A0010"                                 'Alpha 1st low non com
                Set SlotLookup1 = SlotWs1.Range(SR17)
            Case "A0011" To "A0499"                                 'Alpha 1st low
                Set SlotLookup1 = SlotWs1.Range(SR3)
            Case "A0500" To "A0633"                                 'Alpha 1st high
                Set SlotLookup1 = SlotWs1.Range(SR1)
            Case "A0634" To "A0999"                                 'Alpha 1st high non com
                Set SlotLookup1 = SlotWs1.Range(SR15)
            Case "A1001" To "A1012"                                 'Alpha 2nd low non com
                Set SlotLookup1 = SlotWs1.Range(SR21)
            Case "A1013" To "A1499"                                 'Alpha 2nd low
                Set SlotLookup1 = SlotWs1.Range(SR7)
            Case "A1500" To "A1752"                                 'Alpha 2nd high
                Set SlotLookup1 = SlotWs1.Range(SR5)
            Case "A1753" To "A1999"                                 'Alpha 2nd high non com
                Set SlotLookup1 = SlotWs1.Range(SR19)
            Case "A2001" To "A2020"                                 'Alpha 3rd low non com
                Set SlotLookup1 = SlotWs1.Range(SR24)
            Case "A2021" To "A2499"                                 'Alpha 3rd low
                Set SlotLookup1 = SlotWs1.Range(SR12)
            Case "A2500" To "A2745"                                 'Alpha 3rd high
                Set SlotLookup1 = SlotWs1.Range(SR9)
            Case "A2746" To "A2999"                                 'Alpha 3rd high non com
                Set SlotLookup1 = SlotWs1.Range(SR23)

            Case "B0001" To "B0010"                                 'Bravo 1st low non com
                Set SlotLookup1 = SlotWs2.Range(SR17)
            Case "B0011" To "B0499"                                 'Bravo 1st low
                Set SlotLookup1 = SlotWs2.Range(SR3)
            Case "B0500" To "B0632"                                 'Bravo 1st high
                Set SlotLookup1 = SlotWs2.Range(SR1)
            Case "B0633" To "B0999"                                 'Bravo 1st high non com
                Set SlotLookup1 = SlotWs2.Range(SR15)
            Case "B1000" To "B1012"                                 'Bravo 2nd low non com
                Set SlotLookup1 = SlotWs2.Range(SR21)
            Case "B1013" To "B1499"                                 'Bravo 2nd low
                Set SlotLookup1 = SlotWs2.Range(SR7)
            Case "B1500" To "B1760"                                 'Bravo 2nd high
                Set SlotLookup1 = SlotWs2.Range(SR5)
            Case "B1761" To "B1999"                                 'Bravo 2nd high non com
                Set SlotLookup1 = SlotWs2.Range(SR19)
            Case "B2000" To "B2020"                                 'Bravo 3rd low non com
                Set SlotLookup1 = SlotWs2.Range(SR24)
            Case "B2021" To "B2499"                                 'Bravo 3rd low
                Set SlotLookup1 = SlotWs2.Range(SR12)
            Case "B2500" To "B2753"                                 'Bravo 3rd high
                Set SlotLookup1 = SlotWs2.Range(SR9)
            Case "B2754" To "B2999"                                 'Bravo 3rd high non com
                Set SlotLookup1 = SlotWs2.Range(SR23)

            Case "C0001" To "C0012"                                 'Charlie 1st low non com
                Set SlotLookup1 = SlotWs3.Range(SR17)
            Case "C0013" To "C0499"                                 'Charlie 1st low
                Set SlotLookup1 = SlotWs3.Range(SR3)
            Case "C0500" To "C0635"                                 'Charlie 1st high
                Set SlotLookup1 = SlotWs3.Range(SR1)
            Case "C0636" To "C0999"                                 'Charlie 1st high non com
                Set SlotLookup1 = SlotWs3.Range(SR15)
            Case "C1000" To "C1016"                                 'Charlie 2nd low non com
                Set SlotLookup1 = SlotWs3.Range(SR21)
            Case "C1017" To "C1499"                                 'Charlie 2nd low
                Set SlotLookup1 = SlotWs3.Range(SR7)
            Case "C1500" To "C1748"                                 'Charlie 2nd high
                Set SlotLookup1 = SlotWs3.Range(SR5)
            Case "C1749" To "C1999"                                 'Charlie 2nd high non com
                Set SlotLookup1 = SlotWs3.Range(SR19)
            Case "C2000" To "C2024"                                 'Charlie 3rd low non com
                Set SlotLookup1 = SlotWs3.Range(SR24)
            Case "C2025" To "C2499"                                 'Charlie 3rd low
                Set SlotLookup1 = SlotWs3.Range(SR12)
            Case "C2500" To "C2749"                                 'Charlie 3rd high
                Set SlotLookup1 = SlotWs3.Range(SR9)
            Case "C2750" To "C2999"                                 'Charlie 3rd high non com
                Set SlotLookup1 = SlotWs3.Range(SR23)

            Case "D0001" To "D0009"                                 'Delta 1st low non com
                Set SlotLookup1 = SlotWs4.Range(SR17)
            Case "D0010" To "D0499"                                 'Delta 1st low
                Set SlotLookup1 = SlotWs4.Range(SR3)
            Case "D0500" To "D0634"                                 'Delta 1st high
                Set SlotLookup1 = SlotWs4.Range(SR1)
            Case "D0635" To "D0999"                                 'Delta 1st high non com
                Set SlotLookup1 = SlotWs4.Range(SR15)
            Case "D1000" To "D1014"                                 'Delta 2nd low non com
                Set SlotLookup1 = SlotWs4.Range(SR21)
            Case "D1015" To "D1499"                                 'Delta 2nd low
                Set SlotLookup1 = SlotWs4.Range(SR7)
            Case "D1500" To "D1753"                                 'Delta 2nd high
                Set SlotLookup1 = SlotWs4.Range(SR5)
            Case "D1754" To "D1999"                                 'Delta 2nd high non com
                Set SlotLookup1 = SlotWs4.Range(SR19)
            Case "D2000" To "D2020"                                 'Delta 3rd low non com
                Set SlotLookup1 = SlotWs4.Range(SR24)
            Case "D2021" To "D2499"                                 'Delta 3rd low
                Set SlotLookup1 = SlotWs4.Range(SR12)
            Case "D2500" To "D2750"                                 'Delta 3rd high
                Set SlotLookup1 = SlotWs4.Range(SR9)
            Case "D2751" To "D2999"                                 'Delta 3rd high non com
                Set SlotLookup1 = SlotWs4.Range(SR23)

            Case "E0001" To "E0010"                                 'Echo 1st low non com
                Set SlotLookup1 = SlotWs5.Range(SR17)
            Case "E0011" To "E0499"                                 'Echo 1st low
                Set SlotLookup1 = SlotWs5.Range(SR3)
            Case "E0500" To "E0638"                                 'Echo 1st high
                Set SlotLookup1 = SlotWs5.Range(SR1)
            Case "E0639" To "E0999"                                 'Echo 1st high non com
                Set SlotLookup1 = SlotWs5.Range(SR15)
            Case "E1000" To "E1019"                                 'Echo 2nd low non com
                Set SlotLookup1 = SlotWs5.Range(SR21)
            Case "E1020" To "E1499"                                 'Echo 2nd low
                Set SlotLookup1 = SlotWs5.Range(SR7)
            Case "E1500" To "E1760"                                 'Echo 2nd high
                Set SlotLookup1 = SlotWs5.Range(SR5)
            Case "E1761" To "E1999"                                 'Echo 2nd high non com
                Set SlotLookup1 = SlotWs5.Range(SR19)
            Case "E2000" To "E2020"                                 'Echo 3rd low non com
                Set SlotLookup1 = SlotWs5.Range(SR24)
            Case "E2021" To "E2499"                                 'Echo 3rd low
                Set SlotLookup1 = SlotWs5.Range(SR12)
            Case "E2500" To "E2758"                                 'Echo 3rd high
                Set SlotLookup1 = SlotWs5.Range(SR9)
            Case "E2759" To "E2999"                                 'Echo 3rd high non com
                Set SlotLookup1 = SlotWs5.Range(SR23)

            Case "F0001" To "F0053"                                 'Fox 1st low non com
                Set SlotLookup1 = SlotWs6.Range(SR17)
            Case "F0054" To "F0499"                                 'Fox 1st low
                Set SlotLookup1 = SlotWs6.Range(SR3)
            Case "F0500" To "F0636"                                 'Fox 1st high
                Set SlotLookup1 = SlotWs6.Range(SR1)
            Case "F0637" To "F0999"                                 'Fox 1st high non com
                Set SlotLookup1 = SlotWs6.Range(SR15)
            Case "F1000" To "F1106"                                 'Fox 2nd low non com
                Set SlotLookup1 = SlotWs6.Range(SR21)
            Case "F1107" To "F1499"                                 'Fox 2nd low
                Set SlotLookup1 = SlotWs6.Range(SR7)
            Case "F1500" To "F1757"                                 'Fox 2nd high
                Set SlotLookup1 = SlotWs6.Range(SR5)
            Case "F1758" To "F1999"                                 'Fox 2nd high non com
                Set SlotLookup1 = SlotWs6.Range(SR19)
            Case "F2000" To "F2018"                                 'Fox 3rd low non com
                Set SlotLookup1 = SlotWs6.Range(SR24)
            Case "F2019" To "F2499"                                 'Fox 3rd low
                Set SlotLookup1 = SlotWs6.Range(SR12)
            Case "F2500" To "F2749"                                 'Fox 3rd high
                Set SlotLookup1 = SlotWs6.Range(SR9)
            Case "F2750" To "F2999"                                 'Fox 3rd high non com
                Set SlotLookup1 = SlotWs6.Range(SR23)

            Case "A3500" To "A3899"                                 'Offline A3500
                Set SlotLookup1 = SlotWs7.Range(SR1)
            Case "A3900" To "A3999"                                 'Offline A3900
                Set SlotLookup1 = SlotWs7.Range(SR3)
            Case "B3100" To "B3499"                                 'Offline A3100
                Set SlotLookup1 = SlotWs7.Range(SR5)
            Case "Q0001" To "Q2999"                                 'Aerosol
                Set SlotLookup1 = SlotWs7.Range(SR7)
                
            Case "R8000"                                            'Clear garbage labels
                Slot = ""

            Case "A8000" To "A9999", "I4000" To "I5999", "J4000" To "J4999", "X4000" To "X6999"             'alpha high dpal
                Set SlotLookup1 = SlotWs8.Range(SR1)
                    z = 1
                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                        Set SlotLookup1 = SlotWs9.Range(SR1)
                            z = 2
                            If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                Set SlotLookup1 = SlotWs7.Range(SR18)
                                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                        SlotWs7.Range("AS1").Offset(x).Value = Slot
                                        x = x + 1
                                    End If
                            End If
                    End If
            Case "A4000" To "A7999"                                                                         'alpha low dpal
                Set SlotLookup1 = SlotWs8.Range(SR2)
                    z = 1
                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                        Set SlotLookup1 = SlotWs9.Range(SR2)
                            z = 2
                            If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                Set SlotLookup1 = SlotWs7.Range(SR18)
                                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                        SlotWs7.Range("AS1").Offset(x).Value = Slot
                                        x = x + 1
                                    End If
                            End If
                    End If
            Case "C4000" To "C6999"                                                                         'bravo high dpal
                Set SlotLookup1 = SlotWs8.Range(SR4)
                    z = 1
                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                        Set SlotLookup1 = SlotWs9.Range(SR4)
                            z = 2
                            If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                Set SlotLookup1 = SlotWs7.Range(SR18)
                                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                        SlotWs7.Range("AS1").Offset(x).Value = Slot
                                        x = x + 1
                                    End If
                            End If
                    End If
            Case "B4000" To "B9999", "J6000" To "J9999", "L4000" To "L7999"                                 'bravo low dpal
                Set SlotLookup1 = SlotWs8.Range(SR6)
                    z = 1
                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                        Set SlotLookup1 = SlotWs9.Range(SR6)
                            z = 2
                            If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                Set SlotLookup1 = SlotWs7.Range(SR18)
                                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                        SlotWs7.Range("AS1").Offset(x).Value = Slot
                                        x = x + 1
                                    End If
                            End If
                    End If
            Case "D4000" To "D6999"                                                                         'charlie high dpal
                Set SlotLookup1 = SlotWs8.Range(SR8)
                    z = 1
                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                        Set SlotLookup1 = SlotWs9.Range(SR8)
                            z = 2
                            If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                Set SlotLookup1 = SlotWs7.Range(SR18)
                                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                        SlotWs7.Range("AS1").Offset(x).Value = Slot
                                        x = x + 1
                                    End If
                            End If
                    End If
            Case "C7000" To "C9999"                                                                         'charkie low dpal
                Set SlotLookup1 = SlotWs8.Range(SR11)
                    z = 1
                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                        Set SlotLookup1 = SlotWs9.Range(SR11)
                            z = 2
                            If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                Set SlotLookup1 = SlotWs7.Range(SR18)
                                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                        SlotWs7.Range("AS1").Offset(x).Value = Slot
                                        x = x + 1
                                    End If
                            End If
                    End If
            Case "E4000" To "E6999"                                                                         'delta high dpal
                Set SlotLookup1 = SlotWs8.Range(SR14)
                    z = 1
                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                        Set SlotLookup1 = SlotWs9.Range(SR14)
                            z = 2
                            If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                Set SlotLookup1 = SlotWs7.Range(SR18)
                                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                        SlotWs7.Range("AS1").Offset(x).Value = Slot
                                        x = x + 1
                                    End If
                            End If
                    End If
            Case "D7000" To "D9999"                                                                         'delta low dpal
                Set SlotLookup1 = SlotWs8.Range(SR16)
                    z = 1
                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                        Set SlotLookup1 = SlotWs9.Range(SR16)
                            z = 2
                            If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                Set SlotLookup1 = SlotWs7.Range(SR18)
                                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                        SlotWs7.Range("AS1").Offset(x).Value = Slot
                                        x = x + 1
                                    End If
                            End If
                    End If
            Case "F4000" To "F6999"                                                                         'echo high dpal
                Set SlotLookup1 = SlotWs8.Range(SR18)
                    z = 1
                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                        Set SlotLookup1 = SlotWs9.Range(SR18)
                            z = 2
                            If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                Set SlotLookup1 = SlotWs7.Range(SR18)
                                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                        SlotWs7.Range("AS1").Offset(x).Value = Slot
                                        x = x + 1
                                    End If
                            End If
                    End If
            Case "E7000" To "E9999"                                                                         'echo low dpal
                Set SlotLookup1 = SlotWs8.Range(SR20)
                    z = 1
                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                        Set SlotLookup1 = SlotWs9.Range(SR20)
                            z = 2
                            If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                Set SlotLookup1 = SlotWs7.Range(SR18)
                                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                        SlotWs7.Range("AS1").Offset(x).Value = Slot
                                        x = x + 1
                                    End If
                            End If
                    End If
            Case "G4000" To "G6999", "Q4000" To "Q9999", "T4000" To "T9999", "W4000" To "W8999"             'fox high dpal
                Set SlotLookup1 = SlotWs8.Range(SR22)
                    z = 1
                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                        Set SlotLookup1 = SlotWs9.Range(SR22)
                            z = 2
                            If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                Set SlotLookup1 = SlotWs7.Range(SR18)
                                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                        SlotWs7.Range("AS1").Offset(x).Value = Slot
                                        x = x + 1
                                    End If
                            End If
                    End If
            Case "F7000" To "F9999"                                                                         'fox low dpal
                Set SlotLookup1 = SlotWs8.Range(SR23)
                    z = 1
                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                        Set SlotLookup1 = SlotWs9.Range(SR23)
                            z = 2
                            If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                Set SlotLookup1 = SlotWs7.Range(SR18)
                                    If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                                        SlotWs7.Range("AS1").Offset(x).Value = Slot
                                        x = x + 1
                                    End If
                            End If
                    End If

            Case Else
                If Len(Slot) > 0 Then
                    Set SlotLookup1 = SlotWs7.Range(SR18)
                        If IsError(Application.Match(Slot, SlotLookup1, 0)) Then
                            SlotWs7.Range("AS1").Offset(x).Value = Slot
                            x = x + 1
                        End If
                End If
            End Select

            If Len(Slot) > 0 Then
                oSet = IIf(LDate >= Date, 2, 3)                                                             'offset for second cell to be incremented
                m = Application.Match(Slot, SlotLookup1, 0)                                                 'faster than `Find()`
                If Not IsError(m) Then                                                                      'got a match?
                    With SlotLookup1.Cells(m)
                        If Answer = 6 Then
                            If z = 1 Or z = 2 Then
                                .Offset(0, oSet).Value = .Offset(0, oSet).Value + 1
                            Else
                                .Offset(0, 1).Value = .Offset(0, 1).Value + 1                                       'increment cell values
                                .Offset(0, oSet).Value = .Offset(0, oSet).Value + 1
                            End If
                        Else
                            .Offset(0, oSet).Value = .Offset(0, oSet).Value + 1
                        End If
                    End With
                End If
            End If
        z = 0
        
        Next cl
        
        lEnd = Timer

    Debug.Print "Duration = " & (lEnd - lStart) & " seconds - End of function"
    
z = vbNull
    
    If Not IsEmpty(z) Then
        Application.ScreenUpdating = True
        Application.Calculation = xlAutomatic
        Exit Sub
    End If

ErrHandler:
    lEnd = Timer
    Debug.Print "Duration = " & (lEnd - lStart) & " seconds - Error Test"
'    MsgBox Err.Description
    Resume Next
    
End Sub

Sub takes 10 minutes to run and sometimes crashes, need help streamlining it

3 Answers3