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]

A Dictionary VBA demonstration for column A as key :​

Sub Demo2()
        Dim V, R&
    With Sheet1.UsedRange.Columns
        If .Count > 5 Then .Item(6).Resize(, .Count - 5).Clear
        V = Application.Index(.Cells, Evaluate("ROW(2:" & .Rows.Count & ")"), [{1,5}])
    With CreateObject("Scripting.Dictionary")
        For R = 1 To UBound(V):  .Item(V(R, 1)) = .Item(V(R, 1)) + V(R, 2):  Next
        V = Application.Transpose(Array(.Keys(), .Items()))
       .RemoveAll
    End With
        .Range("A1,E1").Copy .Range("G1")
        .Range("G2:H2").Resize(UBound(V)).Value2 = V
    End With
End Sub

 

[abdo meghari]

so what's mean number 2 , is it rule ? doesn't relate filtering specific column ?

 

[Marc L]

​

Did you at least open & read the VBA help of Range.AdvancedFilter method ? As all is yet there, a must read ! So according to the Action …​

 

[abdo meghari]

Did you at least open & read the VBA help of Range.AdvancedFilter method ?

no . how open it?

 

[abdo meghari]

based on post#11 it doesn't copy all the columns like OP and seems slow .

 

[johnnyL]

The following code is a dictionary approach that doesn't use an array:

Sub summing_duplicateditems_NoArray()                      ' 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.ClearContents                                            ' Clear any previous values in that table
'
    TableRow = 1                                                        ' 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

 

[Marc L]

based on post#11 it doesn't copy all the columns like OP and seems slow .

Do you compare with post #8 speed execution ?​

​

Post #11 demonstration shows how a Dictionary works just storing an item for each key​

like your original code which does not store all the columns !​

​

So if you really need all the columns​

- seems not necessary as the result in on the same sheet on the same headers row with an unique column as key -​

you can use the fast advanced filter Excel feature like I did in my previous demonstrations and just allocate the Dictionary items to the worksheet result …​

​

 

[Marc L]

According to post #11 speed execution you can avoid to use the Index worksheet function for the first allocation of variable V …​

 

[abdo meghari]

@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?

​

 

[abdo meghari]

Do you compare with post #8 speed execution ?

despite you don't use loop but it gives running speed 0.05 with comparison code in post #16 .that's why I would do by dictionary and array.

Post #11 demonstration shows how a Dictionary works just storing an item for each key
like your original code which does not store all the columns !

but my request how show the others columns by dictionary and array .
the code in post #11 it's too slow . it gives running speed 0.380 with just for 4 rows . there is a problem for the code