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.

 

[abdo meghari]

I try adjusting based on my OP to this

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, "E").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, 2), Data(R, 3), Data(R, 4), Data(R, 5) 'adding first value

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

    Next R

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

End With

End Sub

but gives error and doesn't succeed. can any body guide me please?

 

[Marc L]

Hi, according to Excel basics and Macro Recorder like any Excel beginner operating manually :​

Sub Demo1()
  Const F = "=RC[-5]&""¤""&RC[-4]&""¤""&RC[-3]&""¤""&RC[-2]"
    Dim L&
        Application.ScreenUpdating = False
    With Sheet1.UsedRange.Columns
        If .Count > 5 Then .Item(6).Resize(, .Count - 5).Clear
       .Item("A:D").AdvancedFilter 2, , .Range("G1"), True
        L = .Range("G1").CurrentRegion.Rows.Count
       .Range("F2:F" & .Rows.Count).FormulaR1C1 = F
       .Range("L2:L" & L).FormulaR1C1 = F
       .Range("K2:K" & L).Formula = Replace("=SUMIF($F$2:$F$#,L2,$E$2:$E$#)", "#", .Rows.Count)
       .Range("K2:K" & L).Formula = .Range("K2:K" & L).Value2
       .Range("E1").Copy .Range("K1")
        Union(.Item(6), .Item(12)).Clear
    End With
        Application.ScreenUpdating = True
End Sub

 

[Marc L]

A little optimization in order to allocate the concatenation formula at once :​

Sub Demo1c()
    Dim L&
        Application.ScreenUpdating = False
    With Sheet1.UsedRange.Columns
        If .Count > 5 Then .Item(6).Resize(, .Count - 5).Clear
       .Item("A:D").AdvancedFilter 2, , .Range("G1"), True
        L = .Range("G1").CurrentRegion.Rows.Count
       .Range("F2:F" & .Rows.Count & ",L2:L" & L).FormulaR1C1 = "=RC[-5]&""¤""&RC[-4]&""¤""&RC[-3]&""¤""&RC[-2]"
       .Range("K2:K" & L).Formula = Replace("=SUMIF($F$2:$F$#,L2,$E$2:$E$#)", "#", .Rows.Count)
       .Range("K2:K" & L).Formula = .Range("K2:K" & L).Value2
       .Range("E1").Copy .Range("K1")
        Union(.Item(6), .Item(12)).Clear
    End With
        Application.ScreenUpdating = True
End Sub

 

[abdo meghari]

thanks for your answering. just I had curiosity how fix my errors in some lines .

 

[Marc L]

​

Some logic errors as Copying / Pasting can't be coding …​

​

For a beginner it's easier to maintain with Excel basics rather than some activeX.​

 

[abdo meghari]

What I prefer by dictionary & array. I see this much faster than the others codes even if the code doesn't contain loop.

I no know why , but it's logical any code doesn't contain loop should be faster than loop is by dictionary and array .

 

[Marc L]

As sometimes the Dictionary way is not the more efficient …​

​

And far above all choose the way you are the more able to maintain​

as what if you are offline and your boss ask you a quick update ?!​

​

My demonstration can be simplified with only the column A as the key rather than columns A:D :​

Sub Demo1s()
    Dim L&
        Application.ScreenUpdating = False
    With Sheet1.UsedRange.Columns
        If .Count > 5 Then .Item(6).Resize(, .Count - 5).Clear
       .Item("A:D").AdvancedFilter 2, , .Range("G1"), True
        L = .Range("G1").CurrentRegion.Rows.Count
       .Range("K2:K" & L).Formula = Replace("=SUMIF($A$2:$A$#,G2,$E$2:$E$#)", "#", .Rows.Count)
       .Range("K2:K" & L).Formula = .Range("K2:K" & L).Value2
       .Range("E1").Copy .Range("K1")
    End With
        Application.ScreenUpdating = True
End Sub

 

[abdo meghari]

       .Item("A:D").AdvancedFilter 2, , .Range("G1"), True

.AdvancedFilter 2 do you mean filter data based on column B?

 

[Marc L]

No as you can see in its VBA help and obviously written from columns A:D …​