Speeding up VBA code with large data sets

[draken]

Hi guys, I've written a macro that parses two sheets that have about 100k rows of data and 20k rows of data respectively. It first looks in the smaller one for a machine part number, and for all instances of that part number, looks in the larger sheet for the bill of materials part number that is connected to that machine part number, and then checks to make sure it fits within a certain date requirement, while filtering out any duplicates that may exist in the first sheet. Hopefully that kind of makes sense, it's definitely a confusing macro. Right now I'm running it through 8 different "machines", and the total run time takes almost 2 minutes, and I was hoping it could be sped up somehow.

Sub Raw_Material_Status()
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim n As Double
    Dim StartScheduleRow As Integer
    Dim EndScheduleRow As Integer
    Dim counter As Integer
    Dim counter2 As Integer
    
    Dim bomSheet As Worksheet: Set bomSheet = ThisWorkbook.Worksheets("BOM")
    Dim machineSheet As Worksheet
    Dim netSheet As Worksheet: Set netSheet = ThisWorkbook.Worksheets("Net Requirements")
    
    Dim rng As Range
    Dim netrng As Range
    
    Dim bomPN As String
    
    Dim netDate As Date
    
    Dim dict
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False    'Turns off alerts
        .AlertBeforeOverwriting = False       'Turns off overwrite alerts
        .Calculation = xlCalculationManual
    End With
    
    Dim StartTime As Double
    Dim SecondsElapsed As Double

    StartTime = Timer
    For i = 1 To 8
        Set machineSheet = ThisWorkbook.Worksheets(i)
        
        With machineSheet
            .Unprotect
            
            StartScheduleRow = Application.WorksheetFunction.IfError(Application.Match("Start of Scheduled Orders", .Range("A1:A2000"), 0), 0)
            EndScheduleRow = Application.WorksheetFunction.IfError(Application.Match("End of Scheduled Orders", .Range("A1:A2000"), 0), 0)
            
            
            .Range(.Cells(StartScheduleRow + 2, 14), .Cells(EndScheduleRow - 1, 14)).ClearContents
            
            For j = StartScheduleRow + 2 To EndScheduleRow - 1
                If (Left$(.Cells(j, 4).Value, 2) = "WO" Or Left$(.Cells(j, 4).Value, 2) = "SO") And (Left$(.Cells(j, 38).Value, 4) <> "Done" And Left$(.Cells(j, 38).Value, 5) <> "Today") Then
                    Set rng = bomSheet.Range("B2:B20000").Find(.Cells(j, 25))
                    
                    Set dict = CreateObject("Scripting.Dictionary")
                    
                    If Not rng Is Nothing Then
                        '.cells(j, 25) is the machine part number
                        counter = Application.CountIf(bomSheet.Range("B2:B20000"), .Cells(j, 25).Value)
                        For k = rng.Row To rng.Row + counter - 1
                            'bill of materials part number
                            bomPN = bomSheet.Cells(k, 5)
                            If Left$(bomPN, 4) = "0902" Or Left$(bomPN, 2) = "03" _
                            Or Left$(bomPN, 2) = "04" Or Left$(bomPN, 4) = "0501" Or Left$(bomPN, 4) = "0903" Then
                                Set netrng = netSheet.Range("C2:C100000").Find(bomPN)
                                
                                If Not netrng Is Nothing Then
                                    counter2 = Application.CountIf(netSheet.Range("C2:C100000"), bomPN)
                                    For n = netrng.Row To netrng.Row + counter2 - 1
                                        If netSheet.Cells(n, 6) < 0 Then
                                            netDate = DateValue(netSheet.Cells(n, 4))
                                            
                                            If netDate < .Cells(j, 18) And netDate > Date And DateDiff("d", Date, .Cells(j, 18)) < 91 Then
                                                If dict.exists(bomPN) Then
                                                    GoTo nextone
                                                Else
                                                    dict.Add bomPN, .Cells(j, 25)
                                                
                                                    If .Cells(j, 14).Value = vbNullString Then
                                                        .Cells(j, 14) = "PN " & bomPN & " " & bomSheet.Cells(k, 4) & " off track per net requirements"
                                                    Else
                                                        .Cells(j, 14) = .Cells(j, 14) & ":" & "PN " & bomPN & " " & bomSheet.Cells(k, 4) & " off track per net requirements"
                                                    End If
                                                End If
                                                GoTo nextone
                                            End If
                                        End If
                                    Next n
                                Else
                                    If dict.exists(bomPN) Then
                                        GoTo nextone
                                    Else
                                        dict.Add bomPN, machineSheet.Cells(j, 25)
                                        If .Cells(j, 14).Value = vbNullString Then
                                            .Cells(j, 14) = "Check status PN " & bomPN & " " & bomSheet.Cells(k, 4)
                                        Else
                                            .Cells(j, 14) = .Cells(j, 14) & ":" & "Check status PN " & bomPN & " " & bomSheet.Cells(k, 4)
                                        End If
                                    End If
                                End If
                            End If
nextone:
                        Next k
                    End If
                End If
            Next j
        End With
        ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
        
    Next i
    
    SecondsElapsed = Round(Timer - StartTime, 2)
    'Notify user in seconds
    Debug.Print SecondsElapsed
    
    StartTime = Timer
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .AlertBeforeOverwriting = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

 

[JGordon11]

To dramatically increase the speed of your code, read and write from/to the spreadsheet in bulk - reading a large range to an array, and writing an array back to a correspondingly sized range.
Use looping and other transformations on the arrays not the range. Once the calculations and loops are complete write the data back to desired range in a single step. (Note arrays should be dimensioned (1 to rows, 1 to columns) to match how the range is dimensioned in excel). In general don't access the application in a loop unless the number of iterations is very small.

to demonstrate these two codes do the same thing (increase the value of each cell in A1:A10000 by 1).

SlowSub reads and writes from/to the spreadsheet in a 10000 iteration loop and on my machine it takes about 2.7 seconds, while FastSub does the same thing using an array in 0.075 second - an improvement of about 35X faster. Similar improvement would drop your code execution time from 2 minutes to about 3 to 4 seconds.

Sub SlowSub()
    Dim i As Long, t As Double
    t = Timer
    For i = 1 To 10000
        ActiveSheet.Cells(i, 1) = ActiveSheet.Cells(i, 1) + 1
    Next
    Debug.Print Timer - t
End Sub

Sub FastSub()
    Dim A, i As Long, t As Double
    t = Timer
    A = ActiveSheet.Range("A1:A100000")
    For i = 1 To 10000
        A(i, 1) = A(i, 1) + 1
    Next
    ActiveSheet.Range("A1:A100000") = A
    Debug.Print Timer - t
End Sub