VBA-Schleife, um Zusammenfassung ohne Pivot-Tabelle anzuzeigen

Question

Ich habe Probleme beim Erstellen einer Schleife, um eine Zusammenfassung meiner Tabellendaten zu erhalten. Um meine Frage klar zu machen, beziehen Sie sich auf das Bild unten.

Vielen Dank im Voraus.

Answer 1

Dies ist wahrscheinlich massiv übertrieben, wird aber schnell sein, wenn Sie einen großen Datensatz haben, an dem Sie gerade arbeiten (was wahrscheinlich ist, dass Sie dies einfach von Hand oder mithilfe einer Pivot-Tabelle tun können) . Bitte werfen Sie einen Blick auf die Kommentare und aktualisieren Sie, wo angegeben. Es wird zur Zeit Ausgang E2 auf der Active Zelle aber ich empfehle ActiveSheet Ihren tatsächlichen Blattnamen und E2 an die gewünschte Position

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