检查差异工作表中的列同一工作簿vba

Question

我刚开始玩vba，想找到一种检查两张excel表的方法。我浏览了所有我能在这里找到的关于将excel表格与vba进行比较的答案，最终找到了这个答案VBA-比较R.Katnaan中存在差异的两张表，可获得最佳结果。因此，我正在努力调整并根据我的情况实施它。纸张是目标，并使用输出纸张进行计数以获得结果。工作表是根据输出工作表中的参考动态更改的，用户通过下拉列表决定要检查的文件。该代码总是在目标和计数两张纸上检查具有起始行3的列b。

代码是有效的，但对于大的工作表(超过100行(，它需要很多时间。例如，对于一张有3500行的纸，它花了3分45秒才得出结果，而且上面有错误(结果缺失(。我想是dowhile函数，但我不确定。有没有优化代码的方法？提前感谢您抽出时间。

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

使用字典对象。

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