VBA counting multiple duplicates in array - arrays

Question

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.

Answer 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

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