배열에서 여러 개의 중복을 계산하는 VBA

Question

어젯밤부터 일부 검색을 수행하고 새 코드를 시도했지만 아직 내가 찾던 답변을 찾지 못했습니다.

여러 배열로 작업하고 있지만 한 번에 하나의 배열에서 중복을 찾고 있습니다. 서로 다른 배열에 중복을 두는 것은 중요하지 않습니다. 오직 하나의 배열 내에서만 중복됩니다.

각 배열에는 5와 7 개의 요소가 있습니다. 각 요소는 일부 샘플 배열 될 수있다 (1) 및 제 의 정수이고

배열 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 Duplicates of 3과 DuplicateCount (Array3) = (3, 2)를 나타냅니다.

어레이 4의 경우 3의 복제본 2 개와 2의 복제본 2 개와 고유 한 1 개의 고유 한 1이있는 배열 4를 원합니다. 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 

응용 프로그램에서 위의 코드를 사용하기 전에, 마이크로 소프트 런타임 스크립팅이 활성화되어있는 참조 (->참조하고 확인란을 도구 이동) 있는지 확인하십시오.

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