VBA計數數組中的多個副本

Question

我已經做了一些搜索並嘗試了自昨晚以來的新代碼，但還沒有找到我正在尋找的答案。

我正在處理多個數組，但一次只能在一個數組中查找重複數據。在不同陣列中重複並不重要;只能在單個數組內重複。

每個數組有5到7個元素。 每個元素是1和10之間 的整數一些樣本陣列可以是

數組1 =（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）

等

對於每一個陣列，我都是我想知道有多少重複。也就是，

對於Array1，我想要一個結果數組（1）表示沒有重複，每個元素都是唯一的。 DuplicateCount（Array1）=（1）。

對於Array2，結果數組應該（2,1）表示有2個重複的1，其餘元素是唯一的。 DuplicateCount（Array2）=（2，1）。對於Array3，我想要一個結果數組（3,2），表示有3個重複的3和2個重複項6.重複項數組（Array3）=（3，2）。 （4,2,1），因爲有4個重複的3個，2個重複的2個，1個唯一的1. DuplicateCount（Array4）=（4,2， 1）。

我非常感謝你的幫助。

謝謝。

Answer 1

我認爲字典可能是一個很好的解決方案，因爲它可以將每個唯一的數組數作爲鍵存儲，並將它們作爲值存儲。如果該數字存在於字典中，則其數量將遞增。下面是我實現的：

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 

使用你的應用程序上面的代碼之前，請確保Microsoft腳本運行時啓用引用（去工具 - >參考並檢查其框）。現在，你準備好了，你可以看到完整的劇本在這裏：

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