概要

Excel VBAで与えられた配列から重複しない一意な要素とそれぞれの出現回数を抽出するためのコードです。
以下の動画で使われているものです。

実行環境

以下の環境で動作確認をしました。

Windows11でのExcel 2021

注意点

プログラムの実行については、すべて自己責任で行ってください。実行により発生した、いかなる直接的または間接的被害について、作者はその責任を負いません。

コード

VBA

Option Explicit

Sub TestDuplicateCount()
    ' テストデータ用の配列
    Dim inputArray() As Variant
    ' 重複を削除した一覧を格納する配列
    Dim uniqueArray() As Variant
    ' 重複した要素の個数を格納する配列
    Dim countArray() As Variant
    
    ' テストデータの設定
    inputArray = Array("A", "B", "C", "A", "B", "D", "E", "A", "C")
    
    ' 重複を削除した一覧と個数を取得
    Call CountUniqueElementsAndOccurrences(inputArray, uniqueArray, countArray)
    
    ' 結果の表示
    Dim i As Integer
    For i = LBound(uniqueArray) To UBound(uniqueArray)
        Debug.Print "文字: " & uniqueArray(i) & ", 個数: " & countArray(i)
    Next i
End Sub

Sub AnotherTestDuplicateCount()
    ' テストデータ用の配列
    Dim inputArray() As Variant
    ' 重複を削除した一覧を格納する配列
    Dim uniqueArray() As Variant
    ' 重複した要素の個数を格納する配列
    Dim countArray() As Variant
    
    ' 別のテストデータの設定
    ReDim inputArray(0 To 9)
    inputArray(0) = "Apple"
    inputArray(1) = "Orange"
    inputArray(2) = "Banana"
    inputArray(3) = "Apple"
    inputArray(4) = "Orange"
    inputArray(5) = "Grape"
    inputArray(6) = "Apple"
    inputArray(7) = "Banana"
    inputArray(8) = "Apple"
    inputArray(9) = "Cherry"
    
    ' 重複を削除した一覧と個数を取得
    Call CountUniqueElementsAndOccurrences(inputArray, uniqueArray, countArray)
    
    ' 結果の表示
    Dim i As Integer
    For i = LBound(uniqueArray) To UBound(uniqueArray)
        Debug.Print "果物: " & uniqueArray(i) & ", 個数: " & countArray(i)
    Next i
End Sub


Sub CountUniqueElementsAndOccurrences(ByRef inputArray() As Variant, ByRef uniqueElements() As Variant, ByRef occurrences() As Variant)
    ' 辞書オブジェクトを作成
    Dim elementDictionary As Object
    Set elementDictionary = CreateObject("Scripting.Dictionary")
    
    ' 辞書に要素を追加し、重複の数を数える
    Dim currentElement As Variant
    Dim i As Integer
    For i = LBound(inputArray) To UBound(inputArray)
        ' 現在の要素を取得
        currentElement = inputArray(i)
        If Not elementDictionary.Exists(currentElement) Then
            ' 新しいキーの場合、値を1に設定
            elementDictionary.Add currentElement, 1
        Else
            ' 既存のキーの場合、値を1増やす
            elementDictionary(currentElement) = elementDictionary(currentElement) + 1
        End If
    Next i
    
    ' 重複を削除した一覧と個数を配列に格納
    ReDim uniqueElements(0 To elementDictionary.count - 1)
    ReDim occurrences(0 To elementDictionary.count - 1)
    
    ' 配列に値を代入
    i = 0
    For Each currentElement In elementDictionary.Keys
        ' 重複を削除した一覧に要素を格納
        uniqueElements(i) = currentElement
        ' 重複した要素の個数を格納
        occurrences(i) = elementDictionary(currentElement)
        i = i + 1
    Next currentElement
End Sub