collection duplicate items based on column and summing values

[KalilMe]

hi
I need macro merge duplicate items for about 1000 rows . should merge based on column A and summing values for columns E,G
the data

columns.xlsm
	A	B	C	D	E	F	G
1	CODE	BR	TY	OR	QTY	PRICE	TOTAL
2	fr001	FR	BANANA	TT	200.00	10.00	2,000.00
3	fr002	FR	APPLE	LL	100.00	54.00	5,400.00
4	fr003	VEG	TOMATO	SS	12.00	22.00	264.00
5	fr004	VEG	TOMATO	AA	12.00	23.00	276.00
6	fr001	FR	BANANA	TT	10.00	32.00	320.00
7	fr002	FR	APPLE	LL	20.00	10.00	200.00
8	fr007	TUNA	180G	IND	20.00	23.00	460.00
9	fr008	TUNA	180G	THI	10.00	12.00	120.00
OPER

Cell Formulas
Range	Formula
G2:G9	G2	=E2*F2

result

columns.xlsm
	I	J	K	L	M	N
1	CODE	BR	TY	OR	QTY	TOTAL
2	fr001	FR	BANANA	TT	210.00	2,320.00
3	fr002	FR	APPLE	LL	120.00	5,600.00
4	fr003	FR	PEAR	NN	12.00	264.00
5	fr004	FR	BANANA	QQ	12.00	276.00
6	fr007	VEG	TOMATO	SS	10.00	460.00
7	fr008	VEG	TOMATO	AA	20.00	120.00
OPER

 

[igold]

It would have been nice if your Result data was the same as your source data. For example "fr008" in the source is TUNA, 180G, THI, but in the result you have it listed as VEG, TOMATO, AA in those respective columns. That said, try this:

Sub SumData()

    Dim dic As Object, dic2 As Object
    Dim Data, dki, dki2
    Dim r As Long, x As Long
    
    Data = Sheets("OPER").Range("A2", Sheets("OPER").Cells(Rows.Count, "G").End(xlUp))
    Set dic = CreateObject("Scripting.Dictionary")
    For r = 1 To UBound(Data)
        dic(Data(r, 1)) = dic(Data(r, 1)) + Data(r, 5) * Data(r, 6)
    Next
    Set dic2 = CreateObject("Scripting.Dictionary")
    For r = 1 To UBound(Data)
        dic2(Data(r, 1)) = dic2(Data(r, 1)) + Data(r, 5)
    Next
    dki = Application.Transpose(Array(dic.Keys, dic.Items))
    dki2 = Application.Transpose(Array(dic2.Keys, dic2.Items))
    ReDim Preserve dki(1 To UBound(dki), 1 To 6)

    For r = 1 To UBound(dki)
        For x = 1 To UBound(Data)
            If dki(r, 1) = Data(x, 1) Then
                dki(r, 6) = dki(r, 2)
                dki(r, 2) = Data(x, 2)
                dki(r, 3) = Data(x, 3)
                dki(r, 4) = Data(x, 4)
                dki(r, 5) = dki2(r, 2)
                Exit For
            End If
        Next
    Next
            
    Sheets("OPER").Range("I1:M1") = Array("CODE", "BR", "TY", "OR", "QTY", "TOTAL")
    Sheets("OPER").Range("I2").Resize(UBound(dki, 1), UBound(dki, 2)) = dki
End Sub

 

[KalilMe]

magnificiant ! this is exactly what I want.
my apologies about mistake fr008
just last thing how can I implement your code for multiple sheets . I don't come back here to issue new thread or ask somebody else mod your code
I would to be the code more dynamically .
note: your code doesn't also show the formatting and borders as is in column A: G

 

[igold]

I am glad it worked for you. Thanks for the feedback!

Not 100% sure what you are asking, If you want to use the code on a different sheet, change the sheet name "OPER" to what ever sheet you want to act on. You can do that in a variety of ways. Hard to say what would work best for your situation.

 

[KalilMe]

Not 100% sure what you are asking

I'm asking about others sheets for instance sheets (rep,port,mort) like the same sheet OPER . it should be loop throught for multiple sheets not only one sheet .

 

[igold]

Depending on what the data looks like on the other sheets... If the other sheets were all in the same format for columns and totals as OPER, then you could create a loop to put all the sheets through the code, one at a time. That should not be difficult.

If they are all in the same format, and you supply the names of the other sheets, I can see if I can manage that.

Additionally, if you want Formatting and Borders, perhaps you could Google that and see what you come up with.?

 

[KalilMe]

If the other sheets were all in the same format for columns and totals as OPER, then you could create a loop to put all the sheets through the code, one at a time

can you show me how ? like put the sheets in array ("rep","port","mort").

 

[igold]

See if this does what you want. You are going back and forth between all caps and small case for the sheet names so I put the UCase function in to compensate for that. Also, if you want to add more sheet names, I indicated where in the code...

Sub SumData2()

    Dim dic As Object, dic2 As Object
    Dim Data, dki, dki2, Snam
    Dim r As Long, x As Long, n As Long
    
    Application.ScreenUpdating = False
    Snam = Array("OPER", "rep", "port", "mort")     '*** Add more sheet names here ***
    For n = 0 To UBound(Snam)
        Data = Sheets(UCase(Snam(n))).Range("A2", Sheets(UCase(Snam(n))).Cells(Rows.Count, "G").End(xlUp))
        Set dic = CreateObject("Scripting.Dictionary")
        For r = 1 To UBound(Data)
            dic(Data(r, 1)) = dic(Data(r, 1)) + Data(r, 5) * Data(r, 6)
        Next
        Set dic2 = CreateObject("Scripting.Dictionary")
        For r = 1 To UBound(Data)
            dic2(Data(r, 1)) = dic2(Data(r, 1)) + Data(r, 5)
        Next
        dki = Application.Transpose(Array(dic.Keys, dic.Items))
        dki2 = Application.Transpose(Array(dic2.Keys, dic2.Items))
        ReDim Preserve dki(1 To UBound(dki), 1 To 6)
        For r = 1 To UBound(dki)
            For x = 1 To UBound(Data)
                If dki(r, 1) = Data(x, 1) Then
                    dki(r, 6) = dki(r, 2)
                    dki(r, 2) = Data(x, 2)
                    dki(r, 3) = Data(x, 3)
                    dki(r, 4) = Data(x, 4)
                    dki(r, 5) = dki2(r, 2)
                    Exit For
                End If
            Next
        Next
        Sheets(UCase(Snam(n))).Range("I1:M1") = Array("CODE", "BR", "TY", "OR", "QTY", "TOTAL")
        Sheets(UCase(Snam(n))).Range("I2").Resize(UBound(dki, 1), UBound(dki, 2)) = dki
        dic.RemoveAll: dic2.RemoveAll: Erase Data: Erase dki: Erase dki2
    Next
    Application.ScreenUpdating = True
    MsgBox "Operation Complete"
    
End Sub

 

[KalilMe]

impressive ! thanks very much for your time and codes.

 

[igold]

You are welcome, I was happy to help. Thanks again for the feedback.