Add multiple values to Dictionary .VBA

Question

i am a absolute newbie in VBA. I want to add more than one value in the Dictonary to group a table with the same values by the Amount of the items. So I have this table

1   10  A5  Text1   Audi1   Auto1   100
2   10  A5  Text1   Audi1   Auto1   100
3   10  A5  Text1   Audi1   Auto1   100
4   10  A4  Text4   Audi4   Auto4   200
5   10  A6  Text5   Audi5   Auto5   300
6   10  A6  Text5   Text5   Text5   300
7   10  A5  Text1   Audi1   Auto1   100
8   10  A4  Text4   Audi4   Auto4   200
9   10  A2  Text9   Audi9   Auto9   50
10  10  A1  Text10  Audi10  Auto10  25

now i want to group then together an it should look like this:

1   40  A5  Text1   Audi1   Auto1   100    
2   20  A4  Text4   Audi4   Auto4   200    
3   20  A6  Text5   Audi5   Auto5   300    
4   10  A2  Text9   Audi9   Auto9   50    
5   10  A1  Text10  Audi10  Auto10  25

My actaul VBA is this:

Sub Schaltfläche1_Klicken()

Dim WkSh    As Worksheet
Dim aTemp   As Variant
Dim lZeile  As Long
Dim rZelle  As Range
Dim Dict    As Variant

   Set WkSh = ThisWorkbook.Worksheets("Tabelle1")

   With WkSh ' die Fahrzeuge aus A2:Bn in einen temporären Array schreiben
      aTemp = .Range("B13:G" & .Cells(.Rows.Count, 1).End(xlUp).Row)
   End With

   WkSh.Range("B13:G1000").ClearContents ' den Bereich D2:E100 leeren/löschen

   Set Dict = CreateObject("Scripting.Dictionary")

   On Error Resume Next

'     die Daten an das Dictionary übergeben
   For lZeile = 1 To UBound(aTemp)
      Dict(aTemp(lZeile, 2)) = Dict(aTemp(lZeile, 2)) + aTemp(lZeile, 1)
      Next lZeile
'
'    ausgeben
'
   Set rZelle = WkSh.Cells(13, 2) ' Bereich festlegen wo hingeschrieben werden soll Beispiel: cells(5,1) -> Reihe 5 Spalte 1
'
   Application.EnableEvents = False
   rZelle.Resize(Dict.Count) = WorksheetFunction.Transpose(Dict.Items)
   rZelle.Offset(0, 1).Resize(Dict.Count) = WorksheetFunction.Transpose(Dict.Keys)
   Application.EnableEvents = True

End Sub

And give me this Output:

1   40  A5
2   20  A4
3   20  A6
4   10  A2
5   10  A1

Can someone please help me, to achive my wanted output.

Answer 1

Using a dictionary. The dictionary keys are created from the concatenation of columns B:F. If the key is already present then the column A value is added to the existing value for that key.

Option Explicit
Public Sub GetTotals()
    Dim inputRange As Range, dict As Object, arr(), i As Long, uniqueKey As String, ws As Worksheet

    Application.ScreenUpdating = False

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set inputRange = ws.Range("A1:F10")
    Set dict = CreateObject("Scripting.Dictionary")
    arr = inputRange.Value

    For i = LBound(arr, 1) To UBound(arr, 1)
        uniqueKey = arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5) & "," & arr(i, 6)
        dict(uniqueKey) = dict(uniqueKey) + arr(i, 1)
    Next i
    Dim key As Variant, tempArr() As String, rowCounter As Long
    rowCounter = inputRange.Offset(inputRange.Rows.Count + 2, 0).Row

    With ws
        For Each key In dict.keys
            .Cells(rowCounter, 1) = dict(key)
            tempArr = Split(key, ",")
            .Cells(rowCounter, 2).Resize(1, UBound(tempArr) + 1) = tempArr
            rowCounter = rowCounter + 1
        Next key
    End With

      Application.ScreenUpdating = True
End Sub

---

Version outputing only 2 columns and ignoring the additional unwanted row:

Option Explicit
Public Sub GetTotals()
    Dim inputRange As Range, dict As Object, arr(), i As Long, uniqueKey As String, ws As Worksheet

    Application.ScreenUpdating = False

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set inputRange = ws.Range("A1:F10")
    Set dict = CreateObject("Scripting.Dictionary")
    arr = inputRange.Value

    For i = LBound(arr, 1) To UBound(arr, 1)
        If Not (arr(i, 4)) = "Text5" Then
            uniqueKey = arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5) & "," & arr(i, 6)
            dict(uniqueKey) = dict(uniqueKey) + arr(i, 1)
        End If
    Next i
    Dim key As Variant, tempArr() As String, rowCounter As Long
    rowCounter = inputRange.Offset(inputRange.Rows.Count + 2, 0).Row

    With ws
        For Each key In dict.keys
            .Cells(rowCounter, 1) = dict(key)
            tempArr = Split(key, ",")

            .Cells(rowCounter, 2) = tempArr(0)
            rowCounter = rowCounter + 1
        Next key
    End With

    Application.ScreenUpdating = True
End Sub

---

Version 1: Data in at top. Data out at bottom.

Version 2: 2 columns; ignore error.

Answer 2

Another Scripting.Dictionary based solution.

Sub Schaltfläche1_Klicken()
    Dim i As Long, j As Long, tmp As String
    Dim aTemp  As Variant, dict As Object

    With ThisWorkbook.Worksheets("Tabelle1")
        aTemp = .Range(.Cells(13, "B"), .Cells(.Rows.Count, "G").End(xlUp)).Value2
        .Range(.Cells(13, "B"), .Cells(.Rows.Count, "G").End(xlUp)).ClearContents

        Set dict = CreateObject("scripting.dictionary")
        dict.comparemode = vbBinaryCompare

        For i = LBound(aTemp, 1) To UBound(aTemp, 1)
            tmp = Join(Array(aTemp(i, 2), aTemp(i, 3), aTemp(i, 4), aTemp(i, 5), aTemp(i, 6)), ChrW(8203))
            dict.Item(tmp) = dict.Item(tmp) + aTemp(i, 1)
        Next i

        With .Cells(13, "B").Resize(dict.Count, 1)
            .Offset(0, -1).Resize(1, 1) = 1
            .Offset(0, -1).Resize(dict.Count, 1).DataSeries Rowcol:=xlColumns, _
                    Type:=xlLinear, Step:=1, Stop:=dict.Count
            .Value = Application.Transpose(dict.items)
            .Offset(0, 1).Value = Application.Transpose(dict.keys)
            .Offset(0, 1).TextToColumns Destination:=.Offset(0, 1), DataType:=xlDelimited, ConsecutiveDelimiter:=False, _
                                        Other:=True, Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
                                        OtherChar:=ChrW(8203), FieldInfo:=Array(Array(1, 1), Array(2, 1))
        End With

    End With

End Sub