Better solution to find and return duplicates in an array

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

CodePudding user response：

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

CodePudding user response：

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