expand code for multiple columns by dictionary & array

[abdo meghari]

hi
I got this code from some forum, but I don't remember who's owner it because it's long time ago in my PC
I implement the code and works for my data .
now I would expand code when show the result should show the items into column G,H,J,I,K based on range A2:E
I put the simple data to understand me what I want .
orginal data

MR.xlsm
	A	B	C	D	E
1	CODE	BRAND	TYPE	ORIGIN	QTY
2	AA	1200R20	G580	JAP	55
3	AA	1200R20	G580	JAP	20
4	BB	1400R20	VSJ	CHI	30
5	BB	1400R20	VSJ	CHI	40
sheet1

result

MR.xlsm
	G	H	I	J	K
1	CODE	BRAND	TYPE	ORIGIN	QTY
2	AA	1200R20	G580	JAP	75
3	BB	1400R20	VSJ	CHI	70
sheet1

and this is the code

Option Base 1
Sub summing_duplicateditems()

Dim Data As Variant, R As Long
Dim QtyDict As Object

Set QtyDict = CreateObject("scripting.dictionary")

Data = Range("A2", Cells(Rows.Count, "D").End(xlUp))

With QtyDict

    For R = 1 To UBound(Data)

        If Not .Exists(Data(R, 1)) Then 'if no dictionary entry for first column then make a new key...
            .Add Data(R, 1), Data(R, 4) 'adding first value

            Else
                .Item(Data(R, 1)) = .Item(Data(R, 1)) + Data(R, 4) ' if existing dictionary, add new value for that item
        End If

    Next R

        Range("F2:F" & .Count + 1) = Application.Transpose(.Keys) ' added 1 to each count (since reporting totals from row 2)
        Range("G2:G" & .Count + 1) = Application.Transpose(.Items)

End With

End Sub

I look forward any one can mod this code.

 

[Marc L]

​

So read posts #17 & 18 and try …​

And post #16 does not use an array …​

 

[Marc L]

but my request how show the others columns by dictionary and array .

So you must first understand how a Dictionary works …​

Then what should be exactly the key to use ?​

In the case only the column A is the key so you can use a single Dictionary and store for each key an array according to columns A:E …​

​

As a reminder for huge data a Dictionary is not always the fastest way.​

​

 

[johnnyL]

@johnnyL fantastic ! your code is fast . the running speed gives from 0.02 to 0.03 , but it clears the headers from column G:K . how fix it please?

​

Sub summing_duplicateditems_NoArrayV2()                      ' More than one item per key in a dictionary without array example
'
'
'   This requires creating a new class Module called 'AF_DictionaryClass'
'       In that Class Module type the following: for example
'           Public AF_DictionaryKey     As String            ' Code
'           Public AF_DictionaryItem1   As String            ' Brand
'           Public AF_DictionaryItem2   As String            ' Type
'           Public AF_DictionaryItem3   As String            ' Origin
'           Public AF_DictionaryItem4   As Long              ' Qty
'
'       That will establish the key and 4 items for the key, make sure you Dim them properly. ;)
'
    Dim ArrayFreeDictionary As AF_DictionaryClass
    Dim TableRow            As Long
    Dim Dict                As Object
    Dim TableStartAddress   As Range
    Dim TableRange          As Range
    Dim Code                As String
    Dim Key                 As Variant
    Dim wsSource            As Worksheet
'
    Set wsSource = Sheets("Sheet1")                                     ' <--- Set this to the proper sheet name
    Set TableStartAddress = wsSource.Range("A1")                        ' <--- Set this to the start address of the table
'
    Set Dict = CreateObject("scripting.dictionary")                     ' Create a Dictionary
    Set TableRange = TableStartAddress.CurrentRegion                    ' Get the TableRange to be used
'
    For TableRow = 2 To TableRange.Rows.count                           ' Loop through Table rows, starting loop with row 2 so we can skip the header row
        Code = TableRange.Cells(TableRow, 1).Value                      '   Save potential Dictionary key into 'Code'
        If Dict.exists(Code) = False Then                               '   If Dictionary key doesn't exist then ...
            Set ArrayFreeDictionary = New AF_DictionaryClass            '       Create new ArrayFreeDictionary Key
            ArrayFreeDictionary.AF_DictionaryKey = Code                 '       Save 'Code' into new ArrayFreeDictionary Key
            Dict.Add Key:=ArrayFreeDictionary.AF_DictionaryKey, Item:=ArrayFreeDictionary   ' Add Items to new ArrayFreeDictionary
        Else
            Set ArrayFreeDictionary = Dict(Code)
        End If
'
        With ArrayFreeDictionary                                        '
            .AF_DictionaryItem1 = TableRange.Cells(TableRow, 2).Value   '       Save Brand into AF_DictionaryItem1
            .AF_DictionaryItem2 = TableRange.Cells(TableRow, 3).Value   '       Save Type into AF_DictionaryItem2
            .AF_DictionaryItem3 = TableRange.Cells(TableRow, 4).Value   '       Save Origin into AF_DictionaryItem1
            .AF_DictionaryItem4 = .AF_DictionaryItem4 + TableRange.Cells(TableRow, 5).Value '       Add Qty to Qty in AF_DictionaryItem4
        End With
    Next
'
    Set TableRange = wsSource.Range("G2").CurrentRegion                 ' Establish Result Table
    TableRange.Offset(1).ClearContents                                  ' Clear any previous values in that table
'
    TableRow = 2                                                        ' Initialize row # of Table
'
    For Each Key In Dict                                                ' Loop through each Dictionary key
        Set ArrayFreeDictionary = Dict(Key)                             '   Save Dictionary Key into ArrayFreeDictionary
'
        With ArrayFreeDictionary                                        '   with the ArrayFreeDictionary ...
            TableRange.Cells(TableRow, 1).Value = .AF_DictionaryKey     '       Display Dictionary Key to Table
            TableRange.Cells(TableRow, 2).Value = .AF_DictionaryItem1   '       Display Dictionary Item1 to Table
            TableRange.Cells(TableRow, 3).Value = .AF_DictionaryItem2   '       Display Dictionary Item2 to Table
            TableRange.Cells(TableRow, 4).Value = .AF_DictionaryItem3   '       Display Dictionary Item3 to Table
            TableRange.Cells(TableRow, 5).Value = .AF_DictionaryItem4   '       Display Dictionary Item4 to Table
        End With
'
        TableRow = TableRow + 1                                         '   Increment the TableRow
    Next                                                                ' Loop back
End Sub

 

[abdo meghari]

As a reminder for huge data a Dictionary is not always the fastest way.

can you tell me how ?
so I will test your code without dictionary for about 1000 rows and johnnyL's code then I will inform you if you're right or wrong .

 

[Marc L]

​

Huge data means more than 400k unique keys where the Dictionary start to be slower & slower so you are far from this size …​

 

[Marc L]

A Dictionary VBA demonstration with columns A:D as keys :​

Sub Demo3()
        Dim V, W, R&
    With Sheet1
       .[G1].CurrentRegion.Offset(1).Clear
        V = .Evaluate(Replace("A2:A#&CHAR(9)&B2:B#&CHAR(9)&C2:C#&CHAR(9)&D2:D#", "#", .UsedRange.Rows.Count))
        W = .Range("E2:E" & UBound(V) + 1).Value2
    With CreateObject("Scripting.Dictionary")
        For R = 1 To UBound(V):  .Item(V(R, 1)) = .Item(V(R, 1)) + W(R, 1):  Next
        V = Application.Transpose(.Keys())
        W = Application.Transpose(.Items())
       .RemoveAll
    End With
        With .[G2].Resize(UBound(V))
             .Value2 = V
             .TextToColumns , 1, xlTextQualifierNone, , True
             .Columns(5).Value2 = W
        End With
    End With
End Sub

 

[abdo meghari]

@johnnyL thanks for fixing and the whole code .

 

[abdo meghari]

@Marc L thanks to give me better way , but I'm too confuesed about your last code . from the first time when there ara just headers from column G: K the code it's slow and gives running speed 2.98 , also show message "There is already data in worksheet, do you want to replace it?"

but not always some time the code is very fast and gives 0.03
I no know what 's the main reason causes it

 

[Marc L]

No such issue on my side …​

 

[Marc L]

thanks to give me better way

It's very not a better way but exactly the same Dictionary way.​

​

So you did not well read my previous directions & explanations (like posts #17 & 18) and it's ttttttiiiiiiiimmmmmmmeeeeeee to learn …​

​