Find duplicates in 2D arrays in VBA

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