Excel Dictionary 入れ子の例

実行結果

コード

Sub prog1()

     Dim i As Integer

     Dim dataNum As Integer

    
     Dim dic As Object
     Dim dKey As Variant
     Dim dicSub As Object
     Dim dKeySub As Variant

     Dim ws As Worksheet

     Set ws = ThisWorkbook.Sheets("辞書")

     ws.Cells.Clear

     Application.ScreenUpdating = False

     dataNum = 10

     For i = 1 To dataNum

        ws.Cells(i, 1).Value = Chr(Int((68 - 65 + 1) * Rnd + 65)) 'A～D
        ws.Cells(i, 2).Value = Chr(Int((67 - 65 + 1) * Rnd + 65)) & "'" 'A'～C'
        ws.Cells(i, 3).Value = Int((900 - 100 + 1) * Rnd + 100) '100～900

     Next

     Set dic = CreateObject("Scripting.Dictionary")

     For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row

       If dic.Exists(ws.Cells(i, 1).Value) = True Then
       
          Set dicSub = dic.Item(ws.Cells(i, 1).Value)

          If dicSub.Exists(ws.Cells(i, 2).Value) = True Then

             dicSub.Item(ws.Cells(i, 2).Value) = dicSub.Item(ws.Cells(i, 2).Value) + ws.Cells(i, 3).Value

          Else

             dicSub.Add ws.Cells(i, 2).Value, ws.Cells(i, 3).Value

          End If

       Else

          Set dicSub = CreateObject("Scripting.Dictionary")

          dicSub.Add ws.Cells(i, 2).Value, ws.Cells(i, 3).Value

          dic.Add ws.Cells(i, 1).Value, dicSub

       End If

     Next

     i = 1

     For Each dKey In dic

         Set dicSub = dic.Item(dKey)

         For Each dKeySub In dicSub

           ws.Cells(i, 5).Value = dKey

           ws.Cells(i, 6).Value = dKeySub

           ws.Cells(i, 7).Value = dicSub.Item(dKeySub)

           i = i + 1

         Next

     Next

     Set dic = Nothing
     Set dKey = Nothing
     Set dicSub = Nothing
     Set dKeySub = Nothing

     ws.Sort.SortFields.Clear

     ws.Sort.SortFields.Add2 Key:=Range("E1:E" & ws.Cells(Rows.Count, 5).End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

     ws.Sort.SortFields.Add2 Key:=Range("F1:F" & ws.Cells(Rows.Count, 5).End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

     With ws.Sort

         .SetRange Range("E1:G" & ws.Cells(Rows.Count, 5).End(xlUp).Row)

         .Header = xlGuess

         .MatchCase = False

         .Orientation = xlTopToBottom

         .SortMethod = xlPinYin

         .Apply

     End With

     Set ws = Nothing

     Application.ScreenUpdating = True

End Sub