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

Question

我和这里有同样的问题：VBA counting multiple duplicates in array，但我还没有找到答案，我的声誉不能在那里发表评论。 我有一个包含 150 个数字的数组，其中可能包含从 1 到 50 的重复数字。数组中并不总是有 50 个数字。我需要的输出示例： - 10 次：1、2； - 20 次：3、4 等； - 0 次：5、6、7 等。 我需要计算 它有多少重复数字的组合，以及 哪些数字 在这些组合中，包括零出现 - 哪些数字不在数组中。 在上面提到的帖子中有解决方案 - 但只有当你知道有多少重复组合时 - 我不知道 - 可能有 1（所有 150 个数字都相等） - ... - 20 ...如果它包含从 1 到 50 的所有数字，则最多 50 个组合，每个组合 3 次。 感谢任何关于如何存储输出的帮助和建议 - 最后应该以上述格式将其写入工作表：[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

我找到了使用 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 函数（在此处找到 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

输出是这样的 [次]> [数字]： （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 - 

Answer 2

创建新数组并计算数量更简单。

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