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

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.