VBA Count multiple duplicates in array

Question

I have the same question as here: VBA counting multiple duplicates in array , but I haven't found an answer and with my reputation can't leave comment there. I have an array with 150 numbers which could contain repetitive numbers from 1 to 50. Not always there are all 50 numbers in the array. Example of output of what I need: - 10 times: 1, 2; - 20 times: 3, 4 etc; - 0 times: 5, 6, 7 etc. I need to count how many combinations of duplicate numbers it has and what numbers are in those combinations including zero occurrence - which numbers are not in the array. On mentioned above post there are solutions - but only when you know how many combinations of duplicates there are - and I don't know it - there could be 1 (all 150 numbers are equal) - ... - 20 ... up to 50 combinations if it contains all numbers from 1 to 50 three times each. Appreciate any help and advice how to store output - finally it should be written to worksheet in the above mentioned format: [times] - [numbers] (here could be a string, example "5 - 6 - 7").

Here is what I've made for 5 combinations, but do 50 cases and then check 50 strings if they are empty or contain something to write to output is not very good option...

For i = 1 To totalNumbers  'my numbers from 1 to 50 or any other number
    numberCount = 0
    For j = 0 To UBound(friendsArray)  'my array of any size (in question said 150)
        If i = friendsArray(j) Then
            numberCount = numberCount + 1
        End If
    Next j
    Select Case numberCount
    Case 0
        zeroString = zeroString & i & " - "
    Case 1
        oneString = oneString & i & " - "
    Case 2
        twoString = twoString & i & " - "
    Case 3
        threeString = threeString & i & " - "
    Case 4
        fourString = fourString & i & " - "
    Case 5
        fiveString = fiveString & i & " - "
    Case Else
    End Select
Next i

Answer 1

I have found possible option using Collection (but have got an headache with getting keys of collection...):

 Dim col As New Collection
 For i = 1 To totalNumbers
    numberCount = 0
    For j = 0 To UBound(friendsArray)
        If i = friendsArray(j) Then
            numberCount = numberCount + 1
        End If
     Next j

    colValue = CStr(numberCount) & "> " & CStr(i) & " - "  'store current combination [key] and number as String

    If IsMissing(col, CStr(numberCount)) Then
        col.Add colValue, CStr(numberCount) 'if current combination of duplicates [key] is missing - add it to collection
    Else  'if current combination [key] is already here - update the value [item]
        oldValue = col(CStr(numberCount))
        newValue = Replace(oldValue & colValue, CStr(numberCount) & "> ", "") 'delete combinations count 
        newValue = CStr(numberCount) & "> " & newValue
        col.Remove CStr(numberCount)        'delete old value
        col.Add newValue, CStr(numberCount) 'write new value with the same key
    End If
Next i

For i = 1 To col.Count
    Debug.Print col(i)
Next i

and IsMissing function (found here How to check the key is exists in collection or not)

Private Function IsMissing(col As Collection, field As String)
    On Error GoTo IsMissingError
    Dim val As Variant
    val = col(field)
    IsMissing = False
    Exit Function
IsMissingError:
    IsMissing = True
End Function

Output is like this [times]> [numbers]: (array of 570 numbers)

114> 2 - 
5> 6 - 
17> 10 - 
10> 3 - 8 - 19 - 21 - 30 - 
6> 1 - 29 - 33 - 
8> 5 - 9 - 13 - 23 - 25 - 28 - 37 - 40 - 
4> 12 - 16 - 41 - 
13> 43 - 
12> 15 - 20 - 22 - 27 - 36 - 38 - 42 - 44 - 45 - 46 - 
9> 4 - 7 - 11 - 14 - 34 - 47 - 48 - 
7> 17 - 18 - 35 - 49 - 
11> 24 - 26 - 31 - 32 - 39 - 50 - 

Answer 2

Creating new array and count the number is more simple.

Sub test()
    Dim friendsArray(0 To 50)
    Dim vTable()
    Dim iMax As Long
    Dim a As Variant, b As Variant
    Dim i As Long, s As Integer, n As Long
    dim c As Integer
    'Create Sample array to Test

    n = UBound(friendsArray)
    For i = 0 To n
        friendsArray(i) = WorksheetFunction.RandBetween(0, 50)
    Next i

   'Your code
    iMax = WorksheetFunction.Max(friendsArray)
    ReDim vTable(0 To iMax) 'create new Array to count

    For i = 0 To n
        c = friendsArray(i)
        vTable(c) = vTable(c) + 1
    Next i

    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")

    For i = 0 To iMax
        If IsEmpty(vTable(i)) Then
            s = 0
        Else
            s = vTable(i)
        End If
        If dic.Exists(s) Then

           dic.Item(s) = dic.Item(s) & " - " & i
        Else
            dic.Add s, i
        End If
    Next i


    a = dic.Keys
    b = dic.Items


    Range("a1").CurrentRegion.Clear
    Range("B:B").NumberFormatLocal = "@"
    Range("a1").Resize(UBound(a) + 1) = WorksheetFunction.Transpose(a)
    Range("b1").Resize(UBound(b) + 1) = WorksheetFunction.Transpose(b)
    Range("a1").CurrentRegion.Sort Range("a1"), xlAscending

End Sub