I have a code that matches a cell value in Column C on Sheet1 to a pivot table on Sheet3 and then copies certain columns over.
- Code will check how many entries there are on Sheet1 that need to be checked
- Loop 2: For every value in Column C/Sheet1 with a match in Column A on Sheet 2 it will then copy over the corresponding data from Column B,C,D,E.
- Since there are multiple matches possible by value/Sheet I am limiting the data pull to three matches (three loops in the code). To achieve that I am increasing i +1 or i+2 to get the next row in the pivot table.
The table on Sheet 2 is sometimes 10,000+ rows and excel crashes.
Does anyone have an idea how to speed up the loop codes (Loop2,3,4 are the same) to make it less work intensive e.g. array possibly? They are causing the lock up since I think the code keeps running up and down column A.
Code
Sub HB_IPT_Rate_Check()
Dim KeyCells As Range
Dim Sheet1, Sheet2, sheet3 As Worksheet
Dim CellChanged As Integer
Dim Path, File As String
Dim LastRow, LastData As Long
Dim Found As Boolean
On Error GoTo Handle
Set Sheet1 = Sheets("Comparison Report")
Sheet1.Range("A1").Clear
If Sheet1.Range("A1").Value = "" Then
Sheet1.Range("A1").Value = 0
CellChanged = Sheet1.Cells(Rows.Count, "C").End(xlUp).Row
End If
If Sheet1.Cells(Rows.Count, "C").End(xlUp).Row > Sheet1.Range("A1").Value Then
CellChanged = Sheet1.Range("A1").Value + 1
'1st Database Match "CPK"
Set Sheet2 = Sheets("CPK")
LastRow = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row
LastData = Sheet1.Cells(Rows.Count, "C").End(xlUp).Row
For i = 1 To LastRow
On Error Resume Next
If Sheet1.Range("C" & CellChanged).Value = "" Then GoTo Nextstep
If Sheet1.Range("C" & CellChanged).Value = Sheet2.Range("A" & i) Then
Sheet1.Range("D" & CellChanged).Value = Sheet2.Range("B" & i).Value 'Sum of HB CWGT (KG)
Sheet1.Range("E" & CellChanged).Value = Sheet2.Range("C" & i).Value 'Sum of MB CWGT (KG)
Sheet1.Range("F" & CellChanged).Value = Sheet2.Range("F" & i).Value 'Achiev CPK
Sheet1.Range("G" & CellChanged).Value = Sheet2.Range("H" & i).Value 'Density
Found = True
End If
If Found = True Or i = LastRow Then
If CellChanged = LastData Then
Exit For
End If
If Found = True Then
Found = False
Nextstep:
CellChanged = CellChanged + 1
End If
i = 0
End If
Next i
'2nd Database Match "Orbit"
Set sheet3 = Sheets("OrbitPivotTable")
CellChanged = Sheet1.Range("A1").Value + 1
LastRow = sheet3.Cells(Rows.Count, "A").End(xlUp).Row
LastData = Sheet1.Cells(Rows.Count, "C").End(xlUp).Row
'Loop1
For i = 1 To LastRow
On Error Resume Next
If Sheet1.Range("C" & CellChanged).Value = "" Then GoTo Nextstep2
If Sheet1.Range("C" & CellChanged).Value = sheet3.Range("A" & i) Then
Sheet1.Range("H" & CellChanged).Value = sheet3.Range("B" & i).Value 'Customer
Sheet1.Range("I" & CellChanged).Value = sheet3.Range("C" & i).Value 'Rate Val start
Sheet1.Range("J" & CellChanged).Value = sheet3.Range("D" & i).Value 'ATA All in
Sheet1.Range("K" & CellChanged).Value = sheet3.Range("E" & i).Value 'Special Remarks
Found = True
End If
If Found = True Or i = LastRow Then
If CellChanged = LastData Then
Exit For
End If
If Found = True Then
Found = False
Nextstep2:
CellChanged = CellChanged + 1
End If
i = 0
End If
Next i
'Loop2
CellChanged = Sheet1.Range("A1").Value + 1
For i = 1 To LastRow
If Sheet1.Range("C" & CellChanged).Value = "" Or Sheet1.Range("C" & CellChanged).Value = "ATA" Then GoTo Nextstep3
If Sheet1.Range("C" & CellChanged).Value = sheet3.Range("A" & i) Then
Sheet1.Range("L" & CellChanged).Value = sheet3.Range("B" & (i + 1)).Value 'Customer
Sheet1.Range("M" & CellChanged).Value = sheet3.Range("C" & (i + 1)).Value 'Rate Val start
Sheet1.Range("N" & CellChanged).Value = sheet3.Range("D" & (i + 1)).Value 'ATA All in
Sheet1.Range("O" & CellChanged).Value = sheet3.Range("E" & (i + 1)).Value 'Special Remarks
Found = True
End If
If Found = True Or i = LastRow Then
If CellChanged = LastData Then
Exit For
End If
If Found = True Then
Found = False
Nextstep3:
CellChanged = CellChanged + 1
End If
i = 0
End If
Next i
Sheet1.Range("L" & 2).Value = sheet3.Range("B" & 1)
Sheet1.Range("M" & 2).Value = sheet3.Range("C" & 1)
Sheet1.Range("N" & 2).Value = sheet3.Range("D" & 1)
Sheet1.Range("O" & 2).Value = sheet3.Range("E" & 1)
'Loop3
CellChanged = Sheet1.Range("A1").Value + 1
For i = 1 To LastRow
On Error Resume Next
If Sheet1.Range("C" & CellChanged).Value = "" Or Sheet1.Range("C" & CellChanged).Value = "ATA" Then GoTo Nextstep4
If Sheet1.Range("C" & CellChanged).Value = sheet3.Range("A" & i) Then
Sheet1.Range("P" & CellChanged).Value = sheet3.Range("B" & (i + 2)).Value 'Customer
Sheet1.Range("Q" & CellChanged).Value = sheet3.Range("C" & (i + 2)).Value 'Rate Val start
Sheet1.Range("R" & CellChanged).Value = sheet3.Range("D" & (i + 2)).Value 'ATA All in
Sheet1.Range("S" & CellChanged).Value = sheet3.Range("E" & (i + 2)).Value 'Special Remarks
Found = True
End If
If Found = True Or i = LastRow Then
If CellChanged = LastData Then
Exit For
End If
If Found = True Then
Found = False
Nextstep4:
CellChanged = CellChanged + 1
End If
i = 0
End If
Next i
Sheet1.Range("P" & 2).Value = sheet3.Range("B" & 1)
Sheet1.Range("Q" & 2).Value = sheet3.Range("C" & 1)
Sheet1.Range("R" & 2).Value = sheet3.Range("D" & 1)
Sheet1.Range("S" & 2).Value = sheet3.Range("E" & 1)
' Workbooks(File).Close savechanges:=False
Sheet1.Range("A1").Value = CellChanged
End If
Exit Sub
Handle:
MsgBox ("Error")
End Sub