Better solution to find and return duplicates in an array - VBA

Question

I am trying to develop a function that will take an array of results containing duplicate values and return an array containing only the duplicated values. The code below does work but I wonder if there is a more elegant / shorter solution?

Sub test()
Dim allFruits(9) As String, manyFruits() As String
allFruits(0) = "plum"
allFruits(1) = "apple"
allFruits(2) = "orange"
allFruits(3) = "banana"
allFruits(4) = "melon"
allFruits(5) = "plum"
allFruits(6) = "kiwi"
allFruits(7) = "nectarine"
allFruits(8) = "apple"
allFruits(9) = "grapes"
manyFruits = duplicates(allFruits())
End Sub

Function duplicates(allFound() As String)
Dim myFound() As String
Dim i As Integer, e As Integer, c As Integer, x As Integer
Dim Comp1 As String, Comp2 As String
Dim found As Boolean
If Len(Join(allFound)) > 0 Then 'Check string array initialised
    If UBound(allFound) > 0 Then
        For c = 0 To UBound(allFound) 'Pass ONLY the duplicates
            Comp1 = allFound(c)
            If Comp1 > "" Then
                For x = c + 1 To UBound(allFound)
                    Comp2 = allFound(x)
                    If Comp1 = Comp2 Then
                        found = True
                        ReDim Preserve myFound(0 To i)
                        myFound(i) = Comp1
                        i = i + 1
                        For e = x To UBound(allFound) 'Delete forward instances of found item
                            If allFound(e) = Comp1 Then
                                allFound(e) = ""
                            End If
                        Next e
                        Exit For
                    End If
                Next x
            End If
        Next c
    Else 'Just one found
        ReDim myFound(0 To 0)
        myFound(0) = allFound(0)
        found = True
    End If
End If
duplicates = myFound
End Function

VBasic2008 · Accepted Answer · 2022-02-18 20:25:59Z

3

Double Dictionary

As String (Exactly the Same Functionality)

Sub test1()
    Dim allFruits(9) As String, manyFruits() As String
    allFruits(0) = "plum"
    allFruits(1) = "apple"
    allFruits(2) = "orange"
    allFruits(3) = "banana"
    allFruits(4) = "melon"
    allFruits(5) = "plum"
    allFruits(6) = "kiwi"
    allFruits(7) = "nectarine"
    allFruits(8) = "apple"
    allFruits(9) = "grapes"
    manyFruits = Duplicates1(allFruits())
    Debug.Print Join(manyFruits, vbLf)
End Sub

Function Duplicates1(StringArray() As String) As String()
    
    Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
    sDict.CompareMode = vbTextCompare
    Dim dDict As Object: Set dDict = CreateObject("Scripting.Dictionary")
    dDict.CompareMode = vbTextCompare
    
    Dim n As Long
    For n = LBound(StringArray) To UBound(StringArray)
        If sDict.Exists(StringArray(n)) Then
            dDict(StringArray(n)) = Empty
        Else
            sDict(StringArray(n)) = Empty
        End If
    Next n
    If dDict.Count = 0 Then Exit Function
    Set sDict = Nothing
    
    Dim arr() As String: ReDim arr(0 To dDict.Count - 1)
    Dim Key As Variant
    n = 0
     
    For Each Key In dDict.Keys
        arr(n) = Key
        n = n + 1
    Next Key
    
    Duplicates1 = arr

End Function

As Variant (Shorter But Different see ' ***)

Sub test2()
    Dim allFruits(9) As String, manyFruits() As Variant ' *** here
    allFruits(0) = "plum"
    allFruits(1) = "apple"
    allFruits(2) = "orange"
    allFruits(3) = "banana"
    allFruits(4) = "melon"
    allFruits(5) = "plum"
    allFruits(6) = "kiwi"
    allFruits(7) = "nectarine"
    allFruits(8) = "apple"
    allFruits(9) = "grapes"
    manyFruits = Duplicates2(allFruits())
    Debug.Print Join(manyFruits, vbLf)
End Sub

Function Duplicates2(StringArray() As String) As Variant ' *** here
    
    Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
    sDict.CompareMode = vbTextCompare
    Dim dDict As Object: Set dDict = CreateObject("Scripting.Dictionary")
    dDict.CompareMode = vbTextCompare
    
    Dim n As Long
    For n = LBound(StringArray) To UBound(StringArray)
        If sDict.Exists(StringArray(n)) Then
            dDict(StringArray(n)) = Empty
        Else
            sDict(StringArray(n)) = Empty
        End If
    Next n
    
    Duplicates2 = dDict.Keys

End Function

answered Feb 18, 2022 at 20:25

VBasic2008

56.9k5 gold badges21 silver badges38 bronze badges

Sign up to request clarification or add additional context in comments.

2 Comments

Saqib Over a year ago

Thank you @VBasic2008 for the introduction to Dictionary. I particularly like the last example and would vote it the best (if I had enough reputation).

VBasic2008 Over a year ago

I would also always use the second solution although it returns a variant array. The contents are strings anyway. You have enough reputation to upvote and from the beginning, you always could have accepted an answer as the best by ticking the checkmark to the left of it.

T.M. · Accepted Answer · 2022-02-19 10:59:53Z

Short approach via FilterXML()

This approach

transforms the base array allFruits into a wellformed xml content using name attributes (nm) and
applies an XPath expression upon all nodes filtering only nodes with siblings via

     "fruits/fruit[(@nm = following-sibling::fruit/@nm)]/@nm"

Instead of explicitly referring to fruits you could also start XPath with //fruit[..." where the double slashes indicate a search at any hierarchy level.

Function MoreThanOne(arr)
'Purp: get only fruits with multiple occurrencies
'Note: reads top to bottom returning the last(!) attribute @nm
'      based on the condition of no following fruit sibling,
'a) create a wellformed xml content string
    Dim content As String
    content = _
        "<fruits><fruit nm='" & _
        Join(arr, "'/><fruit nm='") & _
        "'/></fruits>"
'b) define XPath expression
    Dim XPth As String
    XPth = "/fruits/fruit[(@nm = following-sibling::fruit/@nm)]/@nm"       ' multiple occurrencies
'c) apply FilterXML function
    Dim x: x = Application.FilterXML(content, XPth)
'd) return result(s)
    MoreThanOne = Application.Transpose(x)
    Select Case VarType(x)
        Case vbError
            MoreThanOne = Array("Nothing found")
        Case vbString
            MoreThanOne = Array(x)
        Case Else
            MoreThanOne = Application.Transpose(x)
    End Select
End Function

Example call

Sub testMoreThanOne()
    Dim allFruits(9) As String, manyFruits() As Variant
    allFruits(0) = "plum"
    allFruits(1) = "apple"
    allFruits(2) = "orange"
    allFruits(3) = "banana"
    allFruits(4) = "melon"
    allFruits(5) = "plum"
    allFruits(6) = "kiwi"
    allFruits(7) = "nectarine"
    allFruits(8) = "apple"
    allFruits(9) = "grapes"
    manyFruits = MoreThanOne(allFruits)
    Debug.Print Join(manyFruits, vbLf)     ' ~~> plum|apple
End Sub

Schema of the created xml structure by above array joins

   <fruits>
       <fruit nm='plum'/>
       <fruit nm='apple'/>
       <fruit nm='orange'/>
       <fruit nm='banana'/>
       <fruit nm='melon'/>
       <fruit nm='plum'/>
       <fruit nm='kiwi'/>
       <fruit nm='nectarine'/>
       <fruit nm='apple'/>
       <fruit nm='grapes'/>
   </fruits>

Side note

Of course you might want to get just uniques by only negating the XPath condition in brackets via

    XPth = "/fruits/fruit[not(@nm = following-sibling::fruit/@nm)]/@nm"

chris neilsen · Accepted Answer · 2022-02-18 22:41:12Z

1

My solution...

Sub FindDuplicates()
    Dim VarDat As Variant
    Dim lngz As Long, lngz2 As Long, lngF As Long
    Dim objDict As Object
    Dim b As Boolean
        
    With Sheet1
        Set objDict = CreateObject("Scripting.Dictionary")
        VarDat = .Range("A1:A20").Value2
      
        For lngz = 1 To UBound(VarDat, 1)
            For lngz2 = lngz + 1 To UBound(VarDat, 1)
                If VarDat(lngz, 1) = VarDat(lngz2, 1) Then
                    b = True
                    Exit For
                End If
            Next lngz2
            If b = True Then
                If objDict.Exists(VarDat(lngz, 1)) = False Then
                    objDict.Add VarDat(lngz, 1), 0
                End If
                b = False
            End If
        Next lngz
    
        .Range("D:D").Clear
        .Range("D1:D" & objDict.Count) = Application.Transpose(objDict.keys)
    End With
End Sub

edited Feb 18, 2022 at 22:41

chris neilsen

53.3k10 gold badges91 silver badges127 bronze badges

answered Feb 18, 2022 at 19:56

user18083442

562 bronze badges

1 Comment

chris neilsen Over a year ago

I edited your code to actually make it work. Hope you don't mind (Feel free to roll back if you do)

Collectives™ on Stack Overflow

Better solution to find and return duplicates in an array - VBA

3 Answers 3

Double Dictionary

2 Comments

Comments

1 Comment

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

3 Answers 3

Double Dictionary

2 Comments

Comments

1 Comment

Your Answer

Sign up or log in

Post as a guest

Related