How to compare two sheets in excel & output similarities AND differences?

Question

I have a current code that compares the first two sheets and then outputs the differences in another. I am now trying to figure out how to also output the similarities into another worksheet.

Here is my current code:

Option Explicit

Sub CompareIt()
    Dim ar As Variant
    Dim arr As Variant
    Dim Var As Variant
    Dim v()
    Dim i As Long
    Dim n As Long
    Dim j As Long
    Dim str As String

    ar = Sheet1.Cells(10, 1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        ReDim v(1 To UBound(ar, 2))
        For i = 2 To UBound(ar, 1)
            For n = 1 To UBound(ar, 2)
                str = str & Chr(2) & ar(i, n)
                v(n) = ar(i, n)
            Next
            .Item(str) = v: str = ""
        Next
        ar = Sheet2.Cells(10, 1).CurrentRegion.Resize(, UBound(v)).Value
        For i = 2 To UBound(ar, 1)
            For n = 1 To UBound(ar, 2)
                str = str & Chr(2) & ar(i, n)
                v(n) = ar(i, n)
            Next
            If .exists(str) Then
                .Item(str) = Empty
            Else
                .Item(str) = v
            End If
            str = ""
        Next
        For Each arr In .keys
            If IsEmpty(.Item(arr)) Then .Remove arr
        Next
        Var = .items: j = .Count
    End With
    With Sheet3.Range("a10").Resize(, UBound(ar, 2))
        .CurrentRegion.ClearContents
        .Value = ar
        If j > 0 Then
            .Offset(1).Resize(j).Value = Application.Transpose(Application.Transpose(Var))
        End If
    End With

    Sheet3.Activate
End Sub

Any ideas?

Answer 1

Since your question is:

Any ideas?

I do have an idea that does rely on:

• Your excel license (TEXTJOIN function is available if you have Office 2019, or if you have an Office 365 subscription)
• Your data size (If the resulting string exceeds 32767 characters (cell limit), TEXTJOIN returns the #VALUE! error.)

But it's an idea :)

Sheet1 & Sheet2

Run this code:

Sub Test()

Dim Var() As String
With ThisWorkbook.Sheets("Sheet3")
    Var() = Split(Evaluate("=TEXTJOIN("","",TRUE,IF(Sheet1!A1:A6=TRANSPOSE(Sheet2!A1:A5),Sheet1!A1:A6,""""))"), ",")
    .Cells(1, 1).Resize(UBound(Var) + 1).Value = Application.Transpose(Var)
End With

End Sub

Output on sheet3:

Obviously it's simplified, but you can add variables in the EVALUATE.