比較兩個工作表並將匹配項和唯一值粘貼到同一工作簿的不同工作表中

Question

任何人都可以用一個血腥的宏來幫助我比較包含大量數據行的兩個工作表（Sheet1 和 Sheet2），並將唯一和重復的值粘貼到 Sheet3 和 Sheet4 中？ 下面將隔離 A 列中不在 B 列中的唯一值，並將結果輸出到 D 列。為此，數據必須並排在 A 列和 B 列中。但是在我的情況下，我必須保留我的同一工作簿的工作表 1 列 A 和工作表 2 列 A 中的數據，而且我想將唯一的和重復的數據粘貼到同一工作簿的工作表 3 列 A 和工作表 4 列 A 中。

Sub Compare1() 'Excel VBA to compare 2 lists.
Dim ar as Variant
Dim var()
Dim i As Long
Dim n As Long

ar=Range("a9").CurrentRegion 'Change Input to suit
ReDim var(1 To UBound(ar, 1), 1 To 1)

With Createobject("scripting.dictionary")
.comparemode = 1
For i = 1 To UBound(ar, 1)
.Item(ar(i, 2)) = Empty
Next
For i = 1 To UBound(ar, 1)
If Not .exists(ar(i, 1)) Then
n = n + 1
var(n, 1) = ar(i, 1)
End If
Next
End With
[D9].Resize(n).Value = var 'Change output to suit

End Sub 

Answer 1

我不確定你是否會喜歡這個，但我會這樣做，因為代碼很容易理解。

我創建了 4 個工作表，但我在代碼中使用了工作表代碼名稱。

在這張圖片中（僅用於說明），它顯示了要比較的兩個列表（表格對象）以及將復制到相應工作表的唯一和重復范圍（如果需要，您可以將其放入隱藏工作表中）。

唯一和重復范圍由公式欄中顯示的公式產生。 對於重復項，只需將公式的末尾替換為=1而不是=0 。

當您移動表 2 或移動唯一和重復范圍時，您需要調整代碼。

Sub copyValues()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
    
    ' Sheets code names
    Set ws1 = Sheet1: Set ws2 = Sheet2: Set ws3 = Sheet3: Set ws4 = Sheet4
    
    ' Set listobjects
    Dim olTable1 As ListObject: Set olTable1 = ws1.ListObjects("Table1")
    Dim olTable2 As ListObject: Set olTable2 = ws1.ListObjects("Table2")
    
    ' Set source ranges
    Dim srcRngUniq As Range: Set srcRngUniq = ws1.Range(Cells(5, 11), Cells(5, 11).End(xlDown))
    Dim srcRngDupl As Range: Set srcRngDupl = ws1.Range(Cells(5, 13), Cells(5, 13).End(xlDown))
    
    ' Set destinations ranges
    Dim dstRngUniq As Range: Set dstRngUniq = ws3.Range("A1")
    Dim dstRngDupl As Range: Set dstRngDupl = ws4.Range("A1")
    
    ' Copy Unique values
    srcRngUniq.Copy
    dstRngUniq.PasteSpecial (xlPasteValues)
    
    ' Copy Duplicates values
    srcRngDupl.Copy
    dstRngDupl.PasteSpecial (xlPasteValues)
End Sub

Answer 2

下面的宏將在兩行之間查找重復值和唯一值，然后借助高級過濾器復制唯一值和重復值

 Sub compareData()

    Dim LstRow1B As long
    Dim wb1 As Workbook
    
    LstRow1B = wb1.Sheets(1).Range("B" & Rows.Count).End(xlUp).Row
        
        wb1.Sheets(1).Range("C2:C" & LstRow1B).FormulaR1C1 = _
            "=IF(ISNA(VLOOKUP(RC[-1],C[-2],1,0)),""Unique"", ""Duplicate"")"
         wb1.Sheets(1).Range("C2:C" & LstRow1B).Copy
         wb1.Sheets(1).Range("C2").PasteSpecial Paste:=xlPasteValues

    ~~> AdvancedFilterCopy unique values
       Dim rgData, rgCriteria, rgOutput As Range
      
       Set rgData = wb1.Sheets(1).Range("A1").CurrentRegion
       Set rgCriteria = wb1.Sheets(1).Range("AA1").CurrentRegion
       Set rgOutput = wb1.Sheets(1).Range("F2")
       
       rgData.AdvancedFilter xlFilterCopy, rgCriteria, rgOutput
       
       '~~> AdvancedFilterCopy duplicate values
       Dim rgData1, rgCriteria1, rgOutput1 As Range
      
       Set rgData1 = wb1.Sheets(1).Range("A1").CurrentRegion
       Set rgCriteria1 = wb1.Sheets(1).Range("AA4").CurrentRegion
       Set rgOutput1 = wb1.Sheets(1).Range("H2")
       
       rgData.AdvancedFilter xlFilterCopy, rgCriteria1, rgOutput1    

End Sub