Excel - ある列の一意の値と別の列の対応する値を検索する

Question

2 次元辞書を作成することでこれを実現できます。辞書は一意性を考慮してくれるので、辞書をお勧めします。このタスクを実行するマクロを作成しました (少なくともサンプルデータでは)。最初に 2 次元データ構造を設定し、次にアルファベット順にソートして出力します。このマクロには、ここで見つけたソート関数の簡略版が含まれています。https://exceloffthegrid.com/sorting-an-array-alphabetically-with-vba/

私のマクロでは、データは 1 行目 ( ) からデータを含む最後の行まで読み取られますFor i = 1 To Cells(Row.Count...。必要に応じて調整してください。正しい列文字が設定されている可能性もあります (ActiveSheet.Range を検索すると表示されます)。

ソート関数はアルファベット順にソートするため、ラベル 11 はラベル 2 より前になります。これが問題になる場合は、ラベル配列に 2 番目のソート関数を作成し、比較前にラベルを数値に変換するのが最も簡単な方法だと思います。パフォーマンスがひどく低下することは承知していますが、問題にならないことを願っています :)

まず、マクロはすべての入力行を読み取り、 , 文字で分割します (前のスペースを削除します。コンポーネントとラベルが常にコンマとスペースで区切られている場合は、簡略化できます)。コンポーネントごとに、ラベルが格納されるサブ辞書を作成し、ラベルを入力します。コンポーネントが複数回出現する場合は、既存の辞書が更新されます。これが最初のメイン For ループです。データが設定されている場合は、列 D と E にソートされたデータを出力します。これが 2 番目のメイン For Each ループです。

最後にコードです (シートのコードモジュールではなくワークブックセクションにありますが、そこでも機能します)。

Sub CollectLabels()
    Dim spl() As String
    Dim dict
    Dim subDict
    Dim lbl As String

    ' Collect data into a 2-dimensional dictionary
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        comps = Split(Replace(ActiveSheet.Range("A" & i).Text, " ", ""), ",")
        For Each comp In comps
            If Not dict.Exists(comp) Then
                Set subDict = CreateObject("Scripting.Dictionary")
                dict.Add comp, subDict
            End If
            Labels = Split(Replace(ActiveSheet.Range("B" & i).Text, " ", ""), ",")
            For Each Label In Labels
                dict(comp)(Label) = 1
            Next Label
        Next comp
    Next i

    i = 1
    ' Output the dictionary contents
    For Each Key In SortArray(dict.Keys)
        ActiveSheet.Range("D" & i).Value = Key
        lbl = ""
        For Each Key2 In SortArray(dict(Key).Keys)
            lbl = lbl & Key2 & ", "
        Next Key2
        ActiveSheet.Range("E" & i).Value = lbl
        i = i + 1
    Next Key
End Sub

Function SortArray(arr As Variant)

Dim i As Long
Dim j As Long
Dim Temp

For i = LBound(arr) To UBound(arr) - 1
    For j = i + 1 To UBound(arr)
        If arr(i) > arr(j) Then
            Temp = arr(j)
            arr(j) = arr(i)
            arr(i) = Temp
        End If
    Next j
Next i

SortArray = arr

End Function

Answer 1