Compare two worksheets and paste matches and unique values into separate worksheets of the same workbook

Question

Can anyone please help me with a bloody macro to compare two worksheets (Sheet1 against Sheet2) containing lots of rows with data and paste unique and duplicate values into Sheet3 and Sheet4?? Below will isolate the unique values in column A which are not in column B and will output the results to column D. For this to work the data must be side by side in Column A and Column B. However in my case I must keep my data in Sheet 1 Column A and Sheet 2 Column A of the same workbook and also I would like to paste the unique as well as duplicate one's into Sheet 3 Column A and Sheet 4 Column A of the same workbook.

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

I not sure if you are going to like this, but it's the way I would do it, because the code is very simple to understand.

I created 4 sheets, but I'm using the sheet code names in the code.

In this picture (just for explanation), it shows the two list to be compared (table objects) and the unique and duplicate ranges (that you can put in a hidden sheet if you want) that will be copied to the respective sheets.

Unique and Duplicated ranges result from the formula shown in the formula bar. For the duplicates just replace the end of the formula to be =1 instead of =0 .

You need to adjust the code when you move table 2 or if you move the unique and Duplicated ranges.

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

Below macro will vlookup between two rows for Duplicate and Unique values, and then copy the unique and duplicated values with the help of Advanced filter

 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