Join many columns into just one cell and sum the quantity

[Stacy Rueda]

Hi guys, Thank you in advance to those who can help me. I know there's same issue with mine but I can't find the exactly the same because what i found almost on the internet is just only two columns, but in my case I have four columns. I also found code like below, but like I've said this is just applicable for two columns only.

Option Explicit

Sub Main()
Dim Source As Worksheet: Set Source = ThisWorkbook.Worksheets("Sheet1")
Dim Destination As Worksheet: Set Destination = ThisWorkbook.Worksheets("Sheet3")


Dim Records As Object: Set Records = CreateObject("Scripting.Dictionary")


Dim Data As Variant
Dim Index As Long
Dim Row As Integer: Row = 1


Data = Source.Range("A1", "B" & Source.Rows(Source.UsedRange.Rows.Count).Row).Value2


For Index = LBound(Data, 1) To UBound(Data, 1)
    If Records.Exists(Data(Index, 1)) Then
        Destination.Cells(Records(Data(Index, 1)), 2).Value2 = Destination.Cells(Records(Data(Index, 1)), 2).Value2 & ", " & Data(Index, 2)
    Else
        Records.Add Data(Index, 1), Row
        Destination.Cells(Row, 1).Value2 = Data(Index, 1)
        Destination.Cells(Row, 2).Value2 = Data(Index, 2)
        Row = Row + 1
    End If
Next Index

And this is what I want in my excel: please see picture


[TABLE="width: 470"]
<colgroup><col><col span="2"><col></colgroup><tbody>[TR]
[TD="colspan: 4"]FROM[/TD]
[/TR]
[TR]
[TD]Employee[/TD]
[TD]Location[/TD]
[TD]Description[/TD]
[TD]Quantity[/TD]
[/TR]
[TR]
[TD]Susan[/TD]
[TD]P1[/TD]
[TD]Chef[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD]Susan[/TD]
[TD]P2[/TD]
[TD]Chef[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD]Susan[/TD]
[TD]P3[/TD]
[TD]Chef[/TD]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD]Mart[/TD]
[TD]P0[/TD]
[TD]Washer[/TD]
[TD="align: right"]2[/TD]
[/TR]
[TR]
[TD]Ed[/TD]
[TD]E3[/TD]
[TD]Cleaner[/TD]
[TD="align: right"]10[/TD]
[/TR]
[TR]
[TD]Ed[/TD]
[TD]E4[/TD]
[TD]Cleaner[/TD]
[TD="align: right"]10[/TD]
[/TR]
[TR]
[TD]Ram[/TD]
[TD]G1[/TD]
[TD]Preparation[/TD]
[TD="align: right"]45[/TD]
[/TR]
[TR]
[TD]Ram[/TD]
[TD]G4[/TD]
[TD]Preparation[/TD]
[TD="align: right"]45[/TD]
[/TR]
[TR]
[TD]Ram[/TD]
[TD]G7[/TD]
[TD]Preparation[/TD]
[TD="align: right"]45[/TD]
[/TR]
[TR]
[TD]Ram[/TD]
[TD]G8[/TD]
[TD]Preparation[/TD]
[TD="align: right"]45[/TD]
[/TR]
</tbody>[/TABLE]


[TABLE="width: 314"]
<colgroup><col><col><col><col></colgroup><tbody>[TR]
[TD="colspan: 4"]FROM[/TD]
[/TR]
[TR]
[TD]Employee[/TD]
[TD]Location[/TD]
[TD]Description[/TD]
[TD]Quantity[/TD]
[/TR]
[TR]
[TD]Susan[/TD]
[TD]P1,P2,P3[/TD]
[TD]Chef[/TD]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD]Mart[/TD]
[TD]P0[/TD]
[TD]Washer[/TD]
[TD="align: right"]2[/TD]
[/TR]
[TR]
[TD]Ed[/TD]
[TD]E3,E4[/TD]
[TD]Cleaner[/TD]
[TD="align: right"]20[/TD]
[/TR]
[TR]
[TD]Ram[/TD]
[TD]G1,G4,G7,G8[/TD]
[TD]Preparation[/TD]
[TD="align: right"]180[/TD]
[/TR]
</tbody>[/TABLE]

 

[Marcelo Branco]

Try this macro

Sub aTest()
    Dim Source As Worksheet: Set Source = ThisWorkbook.Worksheets("Sheet1")
    Dim vData As Variant
    
    With Source
        vData = .Range("A2:D" & .Cells(Rows.Count, "A").End(xlUp).Row)
    End With
    
    Dim dic As Object, i As Long
    Dim arrAux As Variant
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    For i = LBound(vData, 1) To UBound(vData, 1)
        If dic.exists(vData(i, 1)) Then
            arrAux = dic(vData(i, 1))
            arrAux(0) = arrAux(0) & ", " & vData(i, 2)
            arrAux(2) = arrAux(2) + vData(i, 4)
            dic(vData(i, 1)) = arrAux
        Else
            dic(vData(i, 1)) = Array(vData(i, 2), vData(i, 3), vData(i, 4))
        End If
    Next i
    
    Dim Destination As Worksheet: Set Destination = ThisWorkbook.Worksheets("Sheet3")
    Dim vResult As Variant, vKey As Variant
    With Destination
        .Columns("A:D").ClearContents
        .Range("A1:D1") = Array("Employee", "Location", "Description", "Quantity")
        vResult = .Range("A2").Resize(dic.Count, 4)
        i = 0
        For Each vKey In dic.keys
            i = i + 1
            vResult(i, 1) = vKey
            vResult(i, 2) = dic(vKey)(0)
            vResult(i, 3) = dic(vKey)(1)
            vResult(i, 4) = dic(vKey)(2)
        Next vKey
        .Range("A2").Resize(dic.Count, 4) = vResult
        .Columns("A:D").AutoFit
    End With
End Sub

Hope this helps

M.

 

[Rick Rothstein]

I was not completely clear on which of those tables was your existing data. I assumed the first table was and that you wanted it changed to the second table. If this is the case, then give this macro a try...

[table="width: 500"]
[tr]
	[td]Sub ReduceData()
  Dim LR As Long, N As Long, Blanks As Variant
  LR = Cells(Rows.Count, "A").End(xlUp).Row
  Range("A2:A" & LR).Value = Evaluate("IF(A2:A" & LR & "=A1:A" & LR - 1 & ","""",A2:A" & LR & ")")
  Set Blanks = Range("A2:A" & LR).SpecialCells(xlBlanks)
  For N = Blanks.Areas.Count To 1 Step -1
    Blanks.Areas(N)(1).Offset(-1, 1) = Join(Application.Transpose(Blanks.Areas(N)(1).Offset(-1, 1).Resize(Blanks.Areas(N).Count + 1)), ",")
    Blanks.Areas(N)(1).Offset(-1, 3) = Application.Sum(Blanks.Areas(N)(1).Offset(-1, 3).Resize(Blanks.Areas(N).Count + 1))
    Blanks.Areas(N).EntireRow.Delete
  Next
End Sub[/td]
[/tr]
[/table]

 

[Stacy Rueda]

Thank you sir @Marcelo Blanco, it really works. you're a genius.

 

[Stacy Rueda]

Thank you sir @Rick Rothstein, thank you for your kindness and sharing your knowledge.

 

[Marcelo Branco]

You are welcome. Glad to help

M.

 

[Stacy Rueda]

Hi sir @Marcelo Blanco, what if the column arranged like below? changes is the arrangement of column but the details is as is..How or what part code will i have to modify? Thanks again.

[TABLE="class: cms_table, width: 470"]
<tbody>[TR]
[TD]Employee[/TD]
[TD]Description[/TD]
[TD]Quantity[/TD]
[TD] Location[/TD]
[/TR]
</tbody>[/TABLE]

 

[Marcelo Branco]

Hi sir @Marcelo Blanco, what if the column arranged like below? changes is the arrangement of column but the details is as is..How or what part code will i have to modify? Thanks again.

[TABLE="class: cms_table, width: 470"]
<tbody>[TR]
[TD]Employee[/TD]
[TD]Description[/TD]
[TD]Quantity[/TD]
[TD] Location[/TD]
[/TR]
</tbody>[/TABLE]

Try this new version

Sub aTestV2()
    Dim Source As Worksheet: Set Source = ThisWorkbook.Worksheets("Sheet1")
    Dim vData As Variant
    
    With Source
        vData = .Range("A2:D" & .Cells(Rows.Count, "A").End(xlUp).Row)
    End With
    
    Dim dic As Object, i As Long
    Dim arrAux As Variant
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    For i = LBound(vData, 1) To UBound(vData, 1)
        If dic.exists(vData(i, 1)) Then
            arrAux = dic(vData(i, 1))
            arrAux(1) = arrAux(1) + vData(i, 3)
            arrAux(2) = arrAux(2) & ", " & vData(i, 4)
            dic(vData(i, 1)) = arrAux
        Else
            dic(vData(i, 1)) = Array(vData(i, 2), vData(i, 3), vData(i, 4))
        End If
    Next i
    
    Dim Destination As Worksheet: Set Destination = ThisWorkbook.Worksheets("Sheet3")
    Dim vResult As Variant, vKey As Variant
    With Destination
        .Columns("A:D").ClearContents
        .Range("A1:D1") = Array("Employee", "Description", "Quantity", "Location")
        vResult = .Range("A2").Resize(dic.Count, 4)
        i = 0
        For Each vKey In dic.keys
            i = i + 1
            vResult(i, 1) = vKey
            vResult(i, 2) = dic(vKey)(0)
            vResult(i, 3) = dic(vKey)(1)
            vResult(i, 4) = dic(vKey)(2)
        Next vKey
        .Range("A2").Resize(dic.Count, 4) = vResult
        .Columns("A:D").AutoFit
    End With
End Sub

M.

 

[Stacy Rueda]

Wow, What a smart person you are sir @Marcelo Branco. Thank you very very very much!!!!

 

[Marcelo Branco]

You are very welcome.

M.