Concatenate and Sum VBA Macro

[ukbulldog001]

Please help in providing macro to concatenate and sum as below table.
Below table starts from A2 to C9 (i'm leaving first row blank to write main header.)

Customer Part Number	Reference Designator	Count
91814232	C339	1
91832745	MN28	1
91832745	MN7	1
91835171	MA2	1
91835171	MA26	1
91839847	MA40	1
91840078	MX1	1

Need the result to be like below table
Below table is the same worksheet from E2 to G7
although header will already be there.

Customer Part Number	Reference Designator	Count
91814232	C339	1
91832745	MN28, MN7	2
91835171	MA2, MA26	2
91839847	MA40	1
91840078	MX1	1

the number of rows is not limited...
thanks in advance.

 

[Georgiboy]

This could also be done with a formula, what version of Excel do you use?

 

[mohadin]

Hi
Try

Sub test()
    Dim a, w
    Dim i&
        a = Cells(1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If Not .exists(a(i, 1)) Then
                .Add a(i, 1), Array(a(i, 1), a(i, 2), 1)
            Else
                w = .Item(a(i, 1))
                w(1) = w(1) & "," & a(i, 2): w(2) = w(2) + 1
                .Item(a(i, 1)) = w
            End If
        Next
        Range("E2").Resize(.Count, 3) = Application.Index(.items, 0, 0)
    End With
End Sub

 

[mohadin]

Ignore the first one and try

Sub test()
    Dim a, w
    Dim i&
        a = Cells(2, 1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If Not .exists(a(i, 1)) Then
                .Add a(i, 1), Array(a(i, 1), a(i, 2), 1)
            Else
                w = .Item(a(i, 1))
                w(1) = w(1) & "," & a(i, 2): w(2) = w(2) + 1
                .Item(a(i, 1)) = w
            End If
        Next
        Range("E1").Resize(.Count, 3) = Application.Index(.items, 0, 0)
    End With
End Sub

 

[ukbulldog001]

Ignore the first one and try

Sub test()
    Dim a, w
    Dim i&
        a = Cells(2, 1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If Not .exists(a(i, 1)) Then
                .Add a(i, 1), Array(a(i, 1), a(i, 2), 1)
            Else
                w = .Item(a(i, 1))
                w(1) = w(1) & "," & a(i, 2): w(2) = w(2) + 1
                .Item(a(i, 1)) = w
            End If
        Next
        Range("E1").Resize(.Count, 3) = Application.Index(.items, 0, 0)
    End With
End Sub

the code somewhat works, I changed the Range("E1") to E2.... please modify the code to keep the headers as it is or you can skip the headers part I will pre fill those headers, consider data from A3 and populate in E3 onwards...

 

[mohadin]

What about

Sub test()
    Dim a, w
    Dim i&
        a = Cells(2, 1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(a)
            If Not .exists(a(i, 1)) Then
                .Add a(i, 1), Array(a(i, 1), a(i, 2), 1)
            Else
                w = .Item(a(i, 1))
                w(1) = w(1) & "," & a(i, 2): w(2) = w(2) + 1
                .Item(a(i, 1)) = w
            End If
        Next
        Range("E3").Resize(.Count, 3) = Application.Index(.items, 0, 0)
    End With
End Sub

 

[ukbulldog001]

What about

Sub test()
    Dim a, w
    Dim i&
        a = Cells(2, 1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(a)
            If Not .exists(a(i, 1)) Then
                .Add a(i, 1), Array(a(i, 1), a(i, 2), 1)
            Else
                w = .Item(a(i, 1))
                w(1) = w(1) & "," & a(i, 2): w(2) = w(2) + 1
                .Item(a(i, 1)) = w
            End If
        Next
        Range("E3").Resize(.Count, 3) = Application.Index(.items, 0, 0)
    End With
End Sub

works well, thanks.

 

[mohadin]

You are very welcome
Thank you for the feedback
Be happy and safe