Home » excel » excel – Find duplicates and list the corresponding values

excel – Find duplicates and list the corresponding values

Posted by: admin May 14, 2020 Leave a comment

Questions:

I have the following code that extracts the duplicates from column B and count the number of duplicates and also lists the values that are in column A that is related to each duplicate value ..

Sub Find_Duplicate()
Dim ky, cl As Range, i As Long
Dim d1 As Object, d2 As Object

Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For Each cl In Range("B2", Range("B" & Rows.Count).End(xlUp))
    d1.Item(cl.Value) = d1.Item(cl.Value) + 1
    d2.Item(cl.Value) = d2.Item(cl.Value) & ";" & cl.Offset(0, -1).Value
Next cl

i = 3
For Each ky In d1.Keys
    If d1.Item(ky) > 1 Then
        i = i + 1
        Cells(i, 5).Resize(1, 3).Value = Array(ky, d1.Item(ky), Mid(d2.Item(ky), 2))
    End If
Next ky
End Sub

In fact the code works fine and with no problems at all

What I am wondering about is there a way to use one dictionary object in this example instead of two instances of dictionary object ..?

How to&Answers:

There are probably many ways to achieve this, but you could try:
Continue using only the second dictionary in your example,
Count the number of delimiters (“;”) in the final value. You could achieve this by:

For Each ky In d2.Keys
    cond = (UBound(Split(d2.Item(ky), ";"))
    If cond > 1 Then
        i = i + 1
        Cells(i, 5).Resize(1, 3).Value = Array(ky, cond, Mid(d2.Item(ky), 2))
    End If
Next ky

You can now delete d1 of your example. Good luck!

Answer:

You can do it this way:

Option Explicit

' Include Tools > References > Microsoft Scripting Runtime

Public Sub Test_FindDuplicates()
    FindDuplicates ActiveSheet.Range("A1:A15"), ActiveSheet.Range("C1")
End Sub

Public Sub FindDuplicates(rngSource As Range, rngDestinationTopLeft As Range, Optional strDelimiter As String = "; ")
    Dim dctUnique As Dictionary: Set dctUnique = New Dictionary
    Dim varValues As Variant: varValues = rngSource.Value
    Dim varValue As Variant: For Each varValue In varValues
        If Not dctUnique.Exists(varValue) Then
            dctUnique.Add varValue, New Collection
        End If
        dctUnique(varValue).Add varValue
    Next
    Dim varOutput() As Variant: ReDim varOutput(1 To dctUnique.Count, 1 To 3)
    Dim r As Long: r = LBound(varOutput, 1)
    Dim varKey As Variant: For Each varKey In dctUnique.Keys
        varOutput(r, 1) = varKey
        Dim strAll As String: strAll = vbNullString
        Dim lngCount As Long: lngCount = 0
        Dim varItem As Variant: For Each varItem In dctUnique.Item(varKey)
            strAll = strAll & strDelimiter & CStr(varItem)
            lngCount = lngCount + 1
        Next
        strAll = Mid(strAll, Len(strDelimiter) + 1)
        varOutput(r, 2) = lngCount
        varOutput(r, 3) = strAll
        r = r + 1
    Next
    rngDestinationTopLeft.Resize(UBound(varOutput, 1) - LBound(varOutput, 1) + 1, UBound(varOutput, 2) - LBound(varOutput, 2) + 1).Value = varOutput
End Sub

Note: Since the duplicate values are all the same, it makes no sense to concatenate them after each other – they are all the same. But you can use this same algorithm e.g. if you want to collect unique values from column A and get the matching values from column B to it.