I just started playing with vba working to find a way to check two excel sheets.I went trough all the answers i could find here about comparing sheets in excel with vba and finally found this answer VBA - Compare Tables on 2 Sheets with Differences from R.Katnaan that gave the best result. So i am trying to adjust and implement it on my situation. The sheets are target and counting with an output sheet for the result. The sheets are dynamically changed of my choosing based on reference in the output sheet where the user decides the files to be checked though a dropdown list. The code always checks the column b with starting row 3 on both sheets target and counting.
The code is working but for large sheets ( more than 100 rows ) it takes to much time . example for a sheet with 3500 rows it took 3 minutes 45 seconds to bring the result and there are mistakes on it ( results missing). i would guess is the do while function but i am not sure.is there a way to optimize the code? Thank you in advance for your time.
Public Sub Compare_sheets()
Dim targetSheet, countingSheet, outputSheet As Worksheet
Dim startrow, outputRow, temptargetRow, tempcountingRow, countingRowCount, targetRowCount, totalRowCount, finishedcountingIndex As Integer
Dim finishedcounting() As String
Dim isExist As Boolean
'Do in background
Application.ScreenUpdating = False
Application.EnableEvents = False
'Set sheets
Set targetSheet = Sheets(Sheets("Compare Sheets").Range("C3").Value)
Set countingSheet = Sheets(Sheets("Compare Sheets").Range("C4").Value)
Set outputSheet = Sheets("Compare Sheets")
'Set start row of each sheet for data
startrow = 3
outputRow = 2
'Get row count from counting sheet and targetsheet
countingRowCount = countingSheet.Range("b" & startrow).End(xlDown).Row
targetRowCount = targetSheet.Range("b" & startrow).End(xlDown).Row
'Check which is bigger
If countingRowCount < targetRowCount Then
totalRowCount = targetRowCount
Else
totalRowCount = countingRowCount
End If
'Set index
finishedcountingIndex = 0
'Re-define array
ReDim finishedcounting(0 To totalRowCount - 1)
'Set the start row
temptargetRow = startrow
'Here I looped with OR state, you can modify it to AND start if you want
Do
'Reset exist flag
isExist = False
'loop all row in counting sheet
For tempcountingRow = 1 To totalRowCount Step 1
'If row is not finished for checking.
If UBound(Filter(finishedcounting, tempcountingRow)) < 0 Then
'If all cell are equal
If targetSheet.Range("b" & temptargetRow) = countingSheet.Range("b" & tempcountingRow) Then
'Set true to exist flag
isExist = True
'Store finished row
finishedcounting(finishedcountingIndex) = tempcountingRow
finishedcountingIndex = finishedcountingIndex 1
'exit looping
Exit For
End If
End If
Next tempcountingRow
'Show result
outputSheet.Range("g" & outputRow) = targetSheet.Range("b" & temptargetRow)
outputSheet.Range("h" & outputRow) = targetSheet.Range("c" & temptargetRow)
outputSheet.Range("i" & outputRow) = targetSheet.Range("d" & temptargetRow)
If isExist Then
outputSheet.Range("f" & outputRow) = "FOUND"
Else
outputSheet.Range("f" & outputRow) = "MISSING"
End If
'increase output row
outputRow = outputRow 1
'go next row
temptargetRow = temptargetRow 1
Loop While targetSheet.Range("B" & temptargetRow) <> vbNullString ' Or targetSheet.Range("B" & temptargetRow) <> "" Or targetSheet.Range("C" & temptargetRow) <> ""
'loop all row in counting sheet
For tempcountingRow = 1 To totalRowCount Step 1
'If row is not finished for checking.
If UBound(Filter(finishedcounting, tempcountingRow)) < 0 Then
'Show result
outputSheet.Range("g" & outputRow) = countingSheet.Range("b" & tempcountingRow)
outputSheet.Range("j" & outputRow) = countingSheet.Range("c" & tempcountingRow)
'outputSheet.Range("C" & outputRow) = countingSheet.Range("C" & tempcountingRow)
outputSheet.Range("f" & outputRow) = "ADDITIONAL"
'increase output row
outputRow = outputRow 1
End If
Next tempcountingRow
'Update
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
CodePudding user response：
Use a Dictionary Object.
Option Explicit
Public Sub Compare_sheets2()
Const ROW_START = 3
Const COL_KEY = "B"
Dim t0 As Single: t0 = Timer
Dim wsTarget As Worksheet, wsCount As Worksheet, wsOutput As Worksheet
Dim lastrow As Long, i As Long, rowOut As Long
Dim dict As Object, key, ar
Set dict = CreateObject("Scripting.Dictionary")
Set wsOutput = Sheets("Compare Sheets")
With wsOutput
Set wsTarget = Sheets(.Range("C3").Value2)
Set wsCount = Sheets(.Range("C4").Value2)
End With
With wsCount
lastrow = .Cells(.Rows.Count, COL_KEY).End(xlUp).Row
ar = .Range("B1:B" & lastrow).Value2
For i = ROW_START To lastrow
key = Trim(ar(i, 1))
If dict.exists(key) Then
MsgBox "Duplicate key '" & key & "'", vbExclamation, wsCount.Name & " Row " & i
Else
dict.Add key, i
End If
Next
End With
rowOut = 2
With wsTarget
lastrow = .Cells(.Rows.Count, COL_KEY).End(xlUp).Row
' FOUND or MISSING
For i = ROW_START To lastrow
key = Trim(.Cells(i, COL_KEY))
' check if col B value exists on wsCount
If dict.exists(key) Then
wsOutput.Cells(rowOut, "F") = "FOUND"
dict(key) = 0 ' mark as found
Else
wsOutput.Cells(rowOut, "F") = "MISSING"
End If
wsOutput.Cells(rowOut, "G").Resize(, 3) = .Cells(i, COL_KEY).Resize(, 3).Value2
rowOut = rowOut 1
Next
' ADDITIONAL
For Each key In dict.keys
i = dict(key) ' row on wsCount
If i > 0 Then
wsOutput.Cells(rowOut, "F") = "ADDITIONAL"
wsOutput.Cells(rowOut, "G") = key
wsOutput.Cells(rowOut, "J") = wsCount.Cells(i, "C").Value2
rowOut = rowOut 1
End If
Next
End With
MsgBox lastrow - ROW_START 1 & " rows scanned on " & wsTarget.Name, _
vbInformation, Format(Timer - t0, "0.0 secs")
End Sub