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
CodePudding user response：
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.
CodePudding user response：
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
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)
.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