配列内に複数の重複を数えるVBA

Question

昨夜からいくつか検索して新しいコードを試しましたが、まだ私が探していた答えが見つかりませんでした。

私は複数の配列で作業していますが、一度に1つの配列で重複を探しています。異なる配列間で重複を持つことは重要ではありません。 1つのアレイ内で重複しています。

各アレイには5と7の要素があります。 各要素はいくつかのサンプルアレイがあってもよい1〜10 の間の整数である

配列1 =（5、6、10、4、2）

配列2 =（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）であり、1の複製が2つあり、残りのelemetsは一意であることを示します。 DuplicateCount（Array2）=（2,1）。

Array3の場合、（3,2）の結果の配列が3つあり、6の複製が2つあることを示します。DuplicateCount（Array3）=（3,2）。

配列4の場合、3の複製が2つと2の複製が2つと固有の1が1つあるので、（4,2,1）という結果の配列が必要です。DuplicateCount（Array4）=（4,2,1） 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