ピボットテーブルを使用しないサマリを表示するVBAループ

Question

テーブルデータをサマリーにするためにループを作成する際に問題があります。 私の質問を明確にするために、以下のイメージを参照してください。

事前にありがとうございます。

Answer 1

これは恐ろしいことですが、作業している大きなデータセットを持っているとすばやくなります（そうしないと、手でやピボットテーブルを使って簡単に行うことができます） 。コメントを見て、記載されているところで更新してください。これは、現在の出力はactivesheetにE2をセルになりますが、私は

Public Sub Example() 
    Dim rng As Range 
    Dim tmpArr As Variant 
    Dim Dict As Object, tmpDict As Object 
    Dim i As Long, j As Long 
    Dim v, key 

    Set Dict = CreateObject("Scripting.Dictionary") 

    ' Update to your sheet here 
    With ActiveSheet 
     ' You may need to modify this depending on where you range is stored 
     Set rng = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 2)) 

     tmpArr = rng.Value 

     For i = LBound(tmpArr, 1) To UBound(tmpArr, 1) 
      ' Test if value exists in dictionary. If not add and set up the dictionary item 
      If Not Dict.exists(tmpArr(i, 1)) Then 
       Set tmpDict = Nothing 
       Set tmpDict = CreateObject("Scripting.Dictionary") 
       Dict.Add key:=tmpArr(i, 1), Item:=tmpDict 
      End If 
      ' Set nested dictionary to variable so we can edit it 
      Set tmpDict = Nothing 
      Set tmpDict = Dict(tmpArr(i, 1)) 

      ' Test if value exists in nested Dictionary, add if not and initiate counter 
      If Not tmpDict.exists(tmpArr(i, 2)) Then 
       tmpDict.Add key:=tmpArr(i, 2), Item:=1 
      Else 
       ' Increment counter if it already exists 
       tmpDict(tmpArr(i, 2)) = tmpDict(tmpArr(i, 2)) + 1 
      End If 
      ' Write nested Dictionary back to Main dictionary 
      Set Dict(tmpArr(i, 1)) = tmpDict 
     Next i 

     ' Repurpose array for output setting to maximum possible size (helps with speed of code) 
     ReDim tmpArr(LBound(tmpArr, 2) To UBound(tmpArr, 2), LBound(tmpArr, 1) To UBound(tmpArr, 1)) 
     ' Set starting counters for array 
     i = LBound(tmpArr, 1) 
     j = LBound(tmpArr, 2) 
     ' Convert dictionary and nested dictionary to flat output 
     For Each key In Dict 
      tmpArr(j, i) = key 
      i = i + 1 
      For Each v In Dict(key) 
       tmpArr(j, i) = v 
       tmpArr(j + 1, i) = Dict(key)(v) 
       i = i + 1 
      Next v 
     Next key 
     ' Reshape array to actual size 
     ReDim Preserve tmpArr(LBound(tmpArr, 1) To UBound(tmpArr, 1), LBound(tmpArr, 2) To i - 1) 
     ' Change this to the starting cell of your output 
     With .Cells(2, 5) 
      Range(.Offset(0, 0), .Cells(UBound(tmpArr, 2), UBound(tmpArr, 1))) = Application.Transpose(tmpArr) 
     End With 
    End With 
End Sub