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:

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

It is better to use adodb and SQL to get the sum. You will then need to know the field name. — Dy.Lee
– Dy.Lee, Commented Jul 10, 2018 at 14:01
The Audi and Auto columns seem to contain 2 extra Text5 values — Slai
– Slai, Commented Jul 10, 2018 at 14:03
Remove that On Error Resume Next in case any errors are being masked. — QHarr
– QHarr, Commented Jul 10, 2018 at 14:11

QHarr · Accepted Answer · 2018-07-10 14:41:09Z

2

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.

edited Jul 10, 2018 at 14:41

answered Jul 10, 2018 at 14:26

QHarr

84.5k14 gold badges58 silver badges105 bronze badges

Sign up to request clarification or add additional context in comments.

7 Comments

WhoAmI Over a year ago

It works but not completely. how can i change the position where i want to put the new output. the rowcounter give me the offset position, but how can i say i want to put the output on ws.Cells(26,2) for example?

QHarr Over a year ago

This line determines where I started outputing: rowCounter = inputRange.Offset(inputRange.Rows.Count + 2, 0).Row

QHarr Over a year ago

simply say rowCounter = 26 to start at row 26.

WhoAmI Over a year ago

But i will accept this for correct answer because the other thing is only optimizing

QHarr Over a year ago

.Cells(rowCounter, 1) = dict(key) is putting the key in column A so if you want key in column B then use .Cells(rowCounter, 2) = dict(key) and .Cells(rowCounter,3) = tempArr(0) That will shift everything to the right one column. The rowCounter just says which row to start writing out at. Put it at what ever value you would like e.g. 26.

|

user4039065 · Accepted Answer · 2018-07-10 14:40:31Z

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

Collectives™ on Stack Overflow

Add multiple values to Dictionary .VBA

2 Answers 2

7 Comments

Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

7 Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related