Find duplicates in 2D arrays in VBA

user_14881718 0
Viewed 82

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

vba excel arrays
2 Answers

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
user_98140690 
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.

user_177629490
Related