Find duplicates in 2D arrays in VBA - arrays

Question

I want a cod that will find duplicates and return it in separate array.
So I found a code that would be perfect for me, but the thing is that this code is removing duplicates. I thought that it will be a simple job to change it, but somehow I cannot manage to do it....
I was thinking that it will be in this part of code If Err.Number <> 0 Then coll.Remove txt but have no idea how to change it. I have tried changing <> with = but it seems not to work.
Can someone tell me where and how should I change the code to get duplicates from 2 arrays.
Sub test()
Dim arr1 As Variant
Dim arr2 As Variant
Dim arr3 As Variant
Dim coll As Collection
Dim I As Long, j As Long, ii As Long, txt As String, x
With Worksheets("Sheet1")
LastRowColumnA = .Cells(.Rows.Count, 1).End(xlUp).Row
arr1 = .Range("A2:C" & LastRowColumnA).Value
End With
With Worksheets("Sheet2")
LastRowColumnA = .Cells(.Rows.Count, 1).End(xlUp).Row
arr2 = .Range("A2:C" & LastRowColumnA).Value
End With
Set coll = New Collection
On Error Resume Next
For I = LBound(arr1, 1) To UBound(arr1, 1)
txt = Join(Array(arr1(I, 1), arr1(I, 2), arr1(I, 3)), Chr(2))
coll.Add txt, txt
Next I
For I = LBound(arr2, 1) To UBound(arr2, 1)
txt = Join(Array(arr2(I, 1), arr2(I, 2), arr2(I, 3)), Chr(2))
Err.Clear
coll.Add txt, txt
If Err.Number <> 0 Then coll.Remove txt
Next I
ReDim arr3(1 To coll.Count, 1 To 3)
For I = 1 To coll.Count
x = Split(coll(I), Chr(2))
For ii = 0 To 2
arr3(I, ii + 1) = x(ii)
Next
Next I
Worksheets("test").Range("A2").Resize(UBound(arr3, 1), 3).Value = arr3
Columns("A:C").EntireColumn.AutoFit
End Sub
Regards,
Timonek

Answer 1

Extract Duplicates
If you set CountSameWorksheetDuplicates to True, it will return the duplicates of each worksheet even if they are not found in the other worksheet.
Option Explicit
Sub ExtractDuplicates()
Const sName1 As String = "Sheet1"
Const sCols1 As String = "A:C"
Const sfRow1 As Long = 2
Const sName2 As String = "Sheet2"
Const sCols2 As String = "A:C"
Const sfRow2 As Long = 2
Const dName As String = "Test"
Const dfCellAddress As String = "A2"
Const CountSameWorksheetDuplicates As Boolean = False
Dim Delimiter As String: Delimiter = Chr(2)
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sData As Variant
sData = RefColumns(wb.Worksheets(sName1).Rows(sfRow1).Columns(sCols1))
Dim cCount As Long: cCount = UBound(sData, 2)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long
Dim sKey As Variant
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
If CountSameWorksheetDuplicates Then
DictAddCount dict, sKey
Else
DictAdd dict, sKey, 1
End If
Next r
sData = RefColumns(wb.Worksheets(sName2).Rows(sfRow2).Columns(sCols2))
If CountSameWorksheetDuplicates Then
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
DictAddCount dict, sKey
Next r
Else
Dim dict2 As Object: Set dict2 = CreateObject("Scripting.Dictionary")
dict2.CompareMode = vbTextCompare
For r = 1 To UBound(sData, 1)
sKey = StrJoinedDataRow(sData, r, Delimiter)
DictAdd dict2, sKey
Next r
For Each sKey In dict2.Keys
DictAddCount dict, sKey
Next sKey
Set dict2 = Nothing
End If
Erase sData
For Each sKey In dict.Keys
If dict(sKey) = 1 Then dict.Remove sKey
Next sKey
Dim drCount As Long: drCount = dict.Count
If drCount = 0 Then Exit Sub
Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
r = 0
Dim c As Long
For Each sKey In dict.Keys
sData = Split(sKey, Delimiter)
r = r + 1
For c = 1 To cCount
dData(r, c) = sData(c - 1)
Next c
Next sKey
Dim drg As Range
Set drg = wb.Worksheets(dName).Range(dfCellAddress).Resize(drCount, cCount)
drg.Value = dData
drg.Resize(drg.Worksheet.Rows.Count - drg.Row - drCount + 1) _
.Offset(drCount).Clear ' clear below
drg.EntireColumn.AutoFit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the range from the first row of a range
' ('FirstRowRange') to the row range containing
' the bottom-most non-empty cell in the row's columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumns( _
ByVal FirstRowRange As Range) _
As Range
If FirstRowRange Is Nothing Then Exit Function
With FirstRowRange.Rows(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Function ' empty range
Set RefColumns = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a row of a 2D array in a delimited string.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function StrJoinedDataRow( _
ByVal Data As Variant, _
ByVal RowIndex As Long, _
Optional ByVal Delimiter As String = " ") _
As String
Const ProcName As String = "StrJoinedDataRow"
On Error GoTo ClearError
Dim c As Long
Dim cString As String
For c = LBound(Data, 2) To UBound(Data, 2)
cString = cString & CStr(Data(RowIndex, c)) & Delimiter
Next c
StrJoinedDataRow = Left(cString, Len(cString) - Len(Delimiter))
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Adds a value ('Key') to a key of an existing ('ByRef')
' dictionary ('dict') adding another value ('Item')
' to the key's associated item.
' Remarks: Error and blank values are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictAdd( _
ByRef dict As Object, _
ByVal Key As Variant, _
Optional ByVal Item As Variant = Empty)
If Not IsError(Key) Then
If Len(Key) > 0 Then
dict(Key) = Item
End If
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Adds a value ('Key') to a key of an existing ('ByRef')
' dictionary ('dict') increasing its count being held
' in the key's associated item.
' Remarks: Error and blank values are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictAddCount( _
ByRef dict As Object, _
ByVal Key As Variant)
If Not IsError(Key) Then
If Len(Key) > 0 Then
dict(Key) = dict(Key) + 1
End If
End If
End Sub

Answer 2

Dim Dict as Object
Dict = CreateObject("Scripting.Dictionary")
Dim Line As Object
For Each line in MyArray
On Error Resume Next
Dict.Add(Line, "")
On Error Goto 0
Next
Dictionaries don't allow duplicate keys. We are only setting keys and ignoring the value by not setting it. The dictionary raises an error if the key exists.