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.
VBA Code:
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