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

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