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

Answer 1

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"

Answer 2

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

Answer 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