Question

自昨晚以来，我已经做了一些搜索并尝试了新的代码，但还没有找到我想要的答案。

我正在处理多个阵列，但我一次只在一个阵列中查找重复项。在不同阵列之间重复并不重要;只在单个数组中重复。

每个数组都有5到7个元素。每个元素都是1到10之间的整数。一些样本数组可以是

Array1 =（5,6,10,4,2）

Array2 =（1,1,9,2,5）

Array3 =（6,3,3,3,6）

Array4 =（1,2,3,3,3,3,2）

等

对于每个阵列，我想知道有多少重复。也就是说，

对于Array1，我想得到一个（1）的结果数组，表明没有重复，每个元素都是唯一的。 DuplicateCount（Array1）=（1）。

对于Array2，结果数组应该（2,1）表示有2个重复的1，其余的元素是唯一的。 DuplicateCount（Array2）=（2,1）。

对于Array3，我想得到一个（3,2）的数组，表示有3个重复的3个和2个重复的6. DuplicateCount（Array3）=（3,2）。

对于数组4，我想要一个（4,2,1）的结果数组，因为有4个重复的3,2个重复的2和1个唯一的1. DuplicateCount（Array4）=（4,2,1））。

我真的很感谢你的帮助。

感谢。

Answer 1

我认为字典对您来说可能是一个很好的解决方案，因为它可以将每个唯一数量的数组存储为键，将它们的计数存储为值。如果数字中存在该数字，则其计数将递增。这是我的实施：

Function DuplicateCount(nums As Variant) As Scripting.Dictionary
    Dim dict As New Scripting.Dictionary
    For Each num In nums
        If dict.Exists(num) Then
            dict(num) = dict(num) + 1
        Else
            dict(num) = 1
        End If
    Next

    Set DuplicateCount = dict
End Function

在您的应用程序中使用上述代码之前，请确保已启用参考 Microsoft Scripting Runtime （转到工具 - ＆gt; 参考并检查其框）。现在你准备好了，你可以在这里看到完整的脚本：

Sub Main()
    Dim array1() As Variant: array1 = Array(5, 6, 10, 4, 2)
    Dim array2() As Variant: array2 = Array(1, 1, 9, 2, 5)
    Dim array3() As Variant: array3 = Array(6, 3, 3, 3, 6)
    Dim array4() As Variant: array4 = Array(1, 2, 3, 3, 3, 3, 2)

    Dim result1 As New Scripting.Dictionary
    Dim result2 As New Scripting.Dictionary
    Dim result3 As New Scripting.Dictionary
    Dim result4 As New Scripting.Dictionary

    Set result1 = DuplicateCount(array1)
    Set result2 = DuplicateCount(array2)
    Set result3 = DuplicateCount(array3)
    Set result4 = DuplicateCount(array4)

    For Each k In result1.Keys()
        If result1(k) > 1 Then
            '(Nothing)
            Debug.Print k & "," & result1(k)
        End If
    Next
    Debug.Print

    For Each k In result2.Keys()
        If result2(k) > 1 Then
            '1,2
            Debug.Print k & "," & result2(k)
        End If
    Next
    Debug.Print

    For Each k In result3.Keys()
        If result3(k) > 1 Then
            '6,2
            '3,3
            Debug.Print k & "," & result3(k)
        End If
    Next
    Debug.Print

    For Each k In result4.Keys()
        If result4(k) > 1 Then
            '2,2
            '3,4
            Debug.Print k & "," & result4(k)
        End If
    Next
End Sub

Function DuplicateCount(nums As Variant) As Scripting.Dictionary
    Dim dict As New Scripting.Dictionary
    For Each num In nums
        If dict.Exists(num) Then
            dict(num) = dict(num) + 1
        Else
            dict(num) = 1
        End If
    Next

    'Debug: Enable the below lines to print the key-value pairs
    'For Each k In dict.Keys()
    '    Debug.Print k & "," & dict(k)
    'Next

    Set DuplicateCount = dict
End Function

Answer 2

Sub tester()
    Debug.Print Join(RepCount(Array(5, 6, 10, 4, 2)), ",")
    Debug.Print Join(RepCount(Array(1, 2, 3, 3, 3, 3, 2)), ",")
    Debug.Print Join(RepCount(Array(6, 3, 3, 3, 6)), ",")
    Debug.Print Join(RepCount(Array(6, 6, 3, 3, 3, 6)), ",")
End Sub



Function RepCount(arrIn)
    Dim rv(), rv2(), i, m, mp, n

    ReDim rv(1 To Application.Max(arrIn))
    ReDim rv2(0 To UBound(rv) - 1)
    For i = 0 To UBound(arrIn)
        rv(arrIn(i)) = rv(arrIn(i)) + 1
    Next i
    For i = 1 To UBound(rv)
        m = Application.Large(rv, i) 'i'th largest rep count
        If IsError(m) Then Exit For 'error=no more reps
        If m <> mp Then 'different from the previous
            rv2(n) = m
            n = n + 1
        End If
        mp = m
    Next i
    ReDim Preserve rv2(0 To n - 1) 'size array to fit content
    RepCount = rv2
End Function

VBA计算数组中的多个重复项

2 个答案: