VBA Подсчет нескольких дубликатов в массиве

Question

У меня тот же вопрос, что и здесь: VBA подсчитывает несколько дубликатов в массиве , но я не нашел ответа и со своей репутацией не могу оставить комментарий там. У меня есть массив из 150 чисел, которые могут содержать повторяющиеся числа от 1 до 50. Не всегда есть все 50 чисел в массиве. Пример вывода того, что мне нужно: - 10 раз: 1, 2; - 20 раз: 3, 4 и т. Д .; - 0 раз: 5, 6, 7 и т. Д. c. Мне нужно подсчитать сколько комбинаций повторяющихся чисел у него есть и какие числа находятся в этих комбинациях, включая нулевое вхождение - каких чисел нет в массиве. В упомянутом выше посте есть решения - но только если вы знаете, сколько комбинаций дубликатов есть - и я не знаю - может быть 1 (все 150 чисел равны) - ... - 20 ... вверх до 50 комбинаций, если он содержит все числа от 1 до 50 три раза каждое. Примите во внимание любую помощь и совет, как хранить выходные данные - наконец, это должно быть записано на лист в указанном выше формате: [times] - [numbers] (здесь может быть строка, пример "5 - 6 - 7").

Вот то, что я сделал для 5 комбинаций, но сделаю 50 случаев, а затем проверим 50 строк, если они пусты или содержат что-то для записи в выходной файл, не очень хороший вариант ...

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

Создать новый массив и посчитать число проще.

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

Answer 2

Я нашел возможный вариант с использованием 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

и функция IsMissing (находится здесь Как проверить, что ключ существует в коллекции или нет )

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

Вывод похож на это [раз]> [числа]: (массив из 570 чисел)

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 -