VBA counting multiple duplicates in array

问题

I've done some search and tried new codes since last night but haven't yet found the answer I was looking for.

I'm working with multiple arrays but am only looking for duplicates in one array at a time. Having duplicates across different arrays doesn't matter; only duplicates within a single array matters.

Each array has between 5 and 7 elements. Each element is an integer between 1 and 10. Some sample arrays can be

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)

etc.

For each array, I would like to know how many duplicates there are. That is,

For Array1, I would like a resulting array of (1) indicating there is no duplicate and each element is unique. DuplicateCount (Array1) = (1).

For Array2, the resulting array should (2, 1) indicating there are 2 duplicates of 1 and the rest of the elemets are unique. DuplicateCount (Array2) = (2, 1).

For Array3, I would like a resulting array of (3, 2) indicating there are 3 duplicates of 3 and 2 duplicates of 6. DuplicateCount (Array3) = (3, 2).

For array 4, I would like a resulting array of (4, 2, 1) as there are 4 duplicates of 3, 2 duplicates of 2, and 1 unique 1. DuplicateCount (Array4) = (4, 2, 1).

I really appreciate all your help.

Thanks.

回答1:

I think a dictionary might be a good solution for you, because it can store each unique number of array as key and their count as value. If the number exists in the dictionary, then its count will be incremented. Here's my implementation:

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

Before using the above code in your application, please ensure that the reference Microsoft Scripting Runtime is enabled (go to Tools -> References and check its box). Now you're ready to go, you can see the full script here:

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

回答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

来源：https://stackoverflow.com/questions/39685123/vba-counting-multiple-duplicates-in-array

标签

arrays

vba

duplicates