concatenate the values and summing with comma

[KalilMe]

hi
I have theses data it should merge duplicated value in COL B,C,D and show all of values even duplicated so the result should show from from I1 : M
in COL J ignore duplicated COL K there is no duplicated based on COL B,C always are different so the duplicated in COL B,C when merge in COL I, J and in COL L should bring all the values and COL M should summing the values

INVE1 (2) (3).xlsm
	A	B	C	D	E
1	item	GOODS	TYPE	PR	QTY
2	1	FR	BANANA	SO	355
3	2	VEG	TOMATO	EG	417
4	3	FO2	TUNE180G	TH	115
5	4	FO1	TUNE160G	SP	55
6	6	FO3	CHEESE CHEEDER	NE	175
7	7	FR	APPLE	TU	125
8	8	VEG	POTATO	GR	180
9	9	FO5	BISCUITS SW	SW	295
10	10	FO1	TUNE160G	IN	151
11	11	FO2	TUNE180G	TW	258
12	12	FO3	CHEESE MOZZIRELA	IT	168
13	13	FO5	BISCUITS SW	SS	1124
14	14	FR	APPLE	IT	463
15	15	VEG	ONION	PO	1580
16	16	VEG	ONION	LOC	1790
17	17	FO6	BISCUITS SW	BR	990
18	18	FO7	BISCUITS SW	IT	550
19	19	FO7	BISCUITS SW	IL	560
20	20	FR	GRAPES	LOC	5
21	14	FR	BANANA	EU	22
RESULT1

expected result

INVE1 (2) (3).xlsm
	I	J	K	L	M
1	GOODS	TYPE	PR	aa	TOTAL
2	FR	BANANA,APPLE, GRAPES	SO,TU,IT, ,LOC,EU	355,125,463, 5,22	970
RESULT1

 

[alansidman]

With Power Pivot, create a measure for each of the values.

Book1
	G	H	I	J	K
1	GOODS	Types	PRs	QTYs	Total
2	FO1	TUNE160G, TUNE160G	SP, IN	55, 151	206
3	FO2	TUNE180G, TUNE180G	TH, TW	115, 258	373
4	FO3	CHEESE CHEEDER, CHEESE MOZZIRELA	NE, IT	175, 168	343
5	FO5	BISCUITS SW, BISCUITS SW	SW, SS	295, 1124	1419
6	FO6	BISCUITS SW	BR	990	990
7	FO7	BISCUITS SW, BISCUITS SW	IT, IL	550, 560	1110
8	FR	BANANA, APPLE, APPLE, GRAPES, BANANA	SO, TU, IT, LOC, EU	355, 125, 463, 5, 22	970
9	VEG	TOMATO, POTATO, ONION, ONION	EG, GR, PO, LOC	417, 180, 1580, 1790	3967
Sheet1

Examples of the Pivot set up and how to create each measure is shown in the pictures.

 

[KalilMe]

thanks for your suggestion . I can't deal with PQ or pivot , so I prefer by macro

 

[Rick Rothstein]

See if this macro does what you want...

Sub Goods()
  Dim X As Long, QTY As Double, Total As Double
  Dim PR As String, Uniques As String
  Dim Ky As Variant, Data As Variant, Rick
  Dim WS As Worksheet
  Set WS = Sheets("Sheet2")
  Data = WS.Range("A1").CurrentRegion.Value
  With CreateObject("Scripting.Dictionary")
    For X = 2 To UBound(Data)
      QTY = Val(.Item(Data(X, 2)))
      PR = Split(.Item(Data(X, 2)) & "+", "+")(1)
      QTY = QTY + Data(X, 5)
      PR = PR & ", " & Data(X, 4)
      .Item(Data(X, 2)) = QTY & "+" & PR
    Next
    Ky = .Keys
    WS.Range("G1:I1") = Array("Goods", "PR", "QTY")
    For X = 0 To .Count - 1
      WS.Cells(X + 2, "G").Value = Ky(X)
      WS.Cells(X + 2, "H").Value = Mid(Split(.Item(Ky(X)), "+")(1), 3)
      WS.Cells(X + 2, "I").Value = Val(.Item(Ky(X)))
    Next
  End With
End Sub

 

[Marcelo Branco]

expected result

GOODS​

TYPE​

PR​

aa​

TOTAL​

FR​

BANANA,APPLE, GRAPES​

SO,TU,IT, ,LOC,EU​

355,125,463, 5,22​

970

Another

If this is the expected output, maybe the macro below (assumes data in Sheet1; output in columns I:M)

Sub aTest()
    Dim dic As Object, vData As Variant
    Dim i As Long, vResult As Variant, vKey As Variant
    Dim arr(0 To 3) As Variant, lRow As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    
    With Sheets("Sheet1")
        vData = .Range("B2:E" & Cells(Rows.Count, "B").End(xlUp).Row)
        For i = 1 To UBound(vData, 1)
            If Not dic.exists(vData(i, 1)) Then
                dic(vData(i, 1)) = Array(vData(i, 2), vData(i, 3), vData(i, 4), vData(i, 4))
            Else
                arr(0) = dic(vData(i, 1))(0)
                If InStr(1, arr(0), vData(i, 2), vbTextCompare) = 0 Then _
                    arr(0) = dic(vData(i, 1))(0) & "," & vData(i, 2)
                arr(1) = dic(vData(i, 1))(1) & "," & vData(i, 3)
                arr(2) = dic(vData(i, 1))(2) & "," & vData(i, 4)
                arr(3) = dic(vData(i, 1))(3) + vData(i, 4)
                dic(vData(i, 1)) = arr
            End If
        Next i
        .Range("I1:M1") = Array("GOODS", "TYPE", "PR", "aa", "TOTAL")
        vResult = .Range("I2").Resize(dic.Count, 5)
        .Range("L2").Resize(dic.Count).NumberFormat = "@"
        For Each vKey In dic.Keys
            lRow = lRow + 1
            vResult(lRow, 1) = vKey
            vResult(lRow, 2) = dic(vKey)(0)
            vResult(lRow, 3) = dic(vKey)(1)
            vResult(lRow, 4) = dic(vKey)(2)
            vResult(lRow, 5) = dic(vKey)(3)
        Next vKey
        .Range("I2").Resize(dic.Count, 5) = vResult
    End With
End Sub

After macro

30062021 Testes.xlsm
	I	J	K	L	M
1	GOODS	TYPE	PR	aa	TOTAL
2	FR	BANANA,APPLE,GRAPES	SO,TU,IT,LOC,EU	355,125,463,5,22	970
3	VEG	TOMATO,POTATO,ONION	EG,GR,PO,LOC	417,180,1580,1790	3967
4	FO2	TUNE180G	TH,TW	115,258	373
5	FO1	TUNE160G	SP,IN	55,151	206
6	FO3	CHEESE CHEEDER,CHEESE MOZZIRELA	NE,IT	175,168	343
7	FO5	BISCUITS SW	SW,SS	295,1124	1419
8	FO6	BISCUITS SW	BR	990	990
9	FO7	BISCUITS SW	IT,IL	550,560	1110
Sheet1

Hope this helps

M.

 

[KalilMe]

@Rick Rothstein thanks but your code miss some data please see my pic2

 

[KalilMe]

@Marcelo Branco fantastic thanks so much
can you add the borders and formatting form col I to M as my source data

 

[Marcelo Branco]

can you add the borders and formatting form col I to M as my source data

Try

Sub aTest()
    Dim dic As Object, vData As Variant
    Dim i As Long, vResult As Variant, vKey As Variant
    Dim arr(0 To 3) As Variant, lRow As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    
    With Sheets("Sheet1")
        vData = .Range("B2:E" & Cells(Rows.Count, "B").End(xlUp).Row)
        For i = 1 To UBound(vData, 1)
            If Not dic.exists(vData(i, 1)) Then
                dic(vData(i, 1)) = Array(vData(i, 2), vData(i, 3), vData(i, 4), vData(i, 4))
            Else
                arr(0) = dic(vData(i, 1))(0)
                If InStr(1, arr(0), vData(i, 2), vbTextCompare) = 0 Then _
                    arr(0) = dic(vData(i, 1))(0) & "," & vData(i, 2)
                arr(1) = dic(vData(i, 1))(1) & "," & vData(i, 3)
                arr(2) = dic(vData(i, 1))(2) & "," & vData(i, 4)
                arr(3) = dic(vData(i, 1))(3) + vData(i, 4)
                dic(vData(i, 1)) = arr
            End If
        Next i
        'Headers
        With .Range("I1:M1")
            .Value = Array("GOODS", "TYPE", "PR", "aa", "TOTAL")
            .Font.Bold = True
            With .Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = -0.149998474074526
                .PatternTintAndShade = 0
            End With
            .Borders.LineStyle = xlContinuous
        End With
        
        vResult = .Range("I2").Resize(dic.Count, 5)
        .Range("L2").Resize(dic.Count).NumberFormat = "@"
        For Each vKey In dic.Keys
            lRow = lRow + 1
            vResult(lRow, 1) = vKey
            vResult(lRow, 2) = dic(vKey)(0)
            vResult(lRow, 3) = dic(vKey)(1)
            vResult(lRow, 4) = dic(vKey)(2)
            vResult(lRow, 5) = dic(vKey)(3)
        Next vKey
        'Result range
        With .Range("I2").Resize(dic.Count, 5)
            .Value = vResult
            .Borders.LineStyle = xlContinuous
        End With
        .Columns("J:L").AutoFit
    End With
End Sub

M.

 

[KalilMe]

@Marcelo Branco great updating !
thanks again for your solution

 

[Marcelo Branco]

You are welcome. Glad to help.

M.