检查不同工作表中的列相同的工作簿 vba

Question

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 

Answer 1

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