查找多个不匹配的单元格并复制到新工作表

Question

我想比较工作表 2 和工作表 1 中的单元格。

首先检查工作表 1 和工作表 2 中区域 A 中的匹配单元格。

接下来，如果没有匹配项，则检查工作表 1 和工作表 2 的范围 B 中的匹配单元格，否则如果有匹配项，则检查范围 A 中的下一个单元格。

如果也没有匹配项，请将工作表 2 中 A 和 B 范围内的这些不匹配单元格复制到新工作表，即工作表 3。

这是我的工作表布局：

工作表 1 -

工作表 2 -

工作表 3 -

这是我的代码（没有按预期工作）：

Dim Cl As Range, Rng As Range, Dic As Object

Set Dic = CreateObject("scripting.dictionary")

With Dic
For Each Cl In MyWorkSheet1Name.Range("A2:B" & MyWorkSheet1Name.Range("B" & Rows.Count).End(xlUp))
    .Item(Cl.Value) = Empty
Next Cl
For Each Cl In MyWorkSheet2Name.Range("A2:B" & MyWorkSheet2Name.Range("B" & Rows.Count).End(xlUp))
    If Not .Exists(Cl.Value) Then
    If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
    End If
Next Cl
End With

If Not Rng Is Nothing Then
    Rng.EntireRow.Copy MyWorkSheet3Name.Range("A" & Rows.Count).End(xlUp)
End If

如何按预期获得运行代码？

非常感谢！

Answer 1

你可以试试这个：

Dim lRow1 As Long, lRow2 As Long

lRow1 = Sheets(1).Range("A" & Sheets(1).Rows.Count).End(xlUp).Row
lRow2 = Sheets(2).Range("A" & Sheets(2).Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

With Sheets(3)
    Sheets(1).Range("A1:B" & lRow1).Copy Destination:=.Range("A1")
    Sheets(2).Range("A2:B" & lRow2).Copy Destination:=.Range("A" & lRow1 + 1)
    
    .Range("C2").Formula = "=COUNTIFS($A:$A$" & lRow1 + lRow2 - 1 & ",A2,$B:$B$" & lRow1 + lRow2 - 1 & ",B2)"
    .Range("C2").AutoFill Destination:=.Range("C2:C" & lRow1 + lRow2 - 1)
    
    .Range("A1").AutoFilter Field:=3, Criteria1:=">1"
    .Rows("2:" & lRow1 + lRow2 - 1).SpecialCells(xlCellTypeVisible).Delete
    .Range("A1").AutoFilter
    .Columns(3).EntireColumn.Delete
End With

Application.ScreenUpdating = True

查找多个不匹配的单元格并复制到新工作表

Find multiple non-matching cells and copy to new worksheet

excel

scripting

vba

dictionary