Question

我有以下代码，用于从B列中提取重复项并计算重复项的数量，还列出了A列中与每个重复项值有关的值。

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

实际上，代码可以正常工作，并且完全没有问题

我想知道的是，在此示例中，是否有一种方法可以使用一个字典对象而不是两个字典对象实例..

Answer 1

可能有很多方法可以实现这一目标，但是您可以尝试：在您的示例中继续仅使用第二个词典，计算最终值中的定界符（“;”）数量。您可以通过以下方式实现此目标：

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

您现在可以删除示例的d1。祝你好运！

Answer 2

您可以这样做：

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

注意：由于重复的值都相同，所以将它们彼此串联起来是没有意义的-它们都是相同的。但是您可以使用相同的算法，例如如果要从A列中收集唯一值并从B列中获取匹配的值。

查找重复项并列出相应的值

2 个答案: