merge data by comma

Kalil

I modified your code but used a different approach, making a dictionary where the key is GOODS but the dictionary Item is an array containing the CSV entries and the sum of QTY. The code below is in new Module 2 in the attached file and I've added comments on the changed bits to explain what's happening.

In the revised file, I've also used the line in bold to remove any duplicates (though not stated in original question):

Option Base 1

Sub SumDictWithArray()

Dim OutDict As Object
Dim TempArr As Variant, GrpArr(1 To 3), X As Long

Set OutDict = CreateObject("scripting.dictionary")

Set WS = Sheets("sheet1")
WS.Range("G2:J" & WS.Range("A" & Rows.Count).End(xlUp).Row) = "" ' clear previous output
Data = WS.Range("A1").CurrentRegion.Value

For X = 2 To UBound(Data)

    If Not OutDict.exists(Data(X, 2)) Then 'if no dictionary entry for GOODS (and there's a QTY), make a new one...
        OutDict.Add Data(X, 2), GrpArr() '...with an array to collect values
        If Not IsNumeric(Data(X, 5)) Then Data(X, 5) = 0 ' set any non-numeric QTY to 0
        OutDict.Item(Data(X, 2)) = Array(Data(X, 3), Data(X, 4), Data(X, 5)) ' add array to dictionary
    Else
        TempArr = OutDict.Item(Data(X, 2)) 'get the existing array

        For n = 1 To 2
            If InStr(1, TempArr(n), Data(X, n + 2), 1) = 0 Then TempArr(n) = TempArr(n) & ", " & Data(X, n + 2) 'Put unique TYP values in 1st element, PR values in 2nd
        Next n

        If IsNumeric(Data(X, 5)) Then TempArr(3) = TempArr(3) + Data(X, 5) 'add only QTY values in 3rd element

        OutDict.Item(Data(X, 2)) = TempArr

    End If

Next X

Ky = OutDict.Keys
WS.Range("G1:J1") = Array("Goods", "TYP", "PR", "QTY")

For X = 0 To OutDict.Count - 1
    WS.Cells(X + 2, "G").Value = Ky(X)
    WS.Cells(X + 2, "H").Value = OutDict.Items()(X)(1)
    WS.Cells(X + 2, "I").Value = OutDict.Items()(X)(2)
    WS.Cells(X + 2, "J").Value = OutDict.Items()(X)(3)
Next X

End Sub

Hope this is what you were after.

Hello Kalil,

When I started writing this code I wanted to make things easier for you to identify, specify and modify columns. Now that it's done I don't think I succeeded :-)  but the code will extract the data you want, and it is possible to identify, specify and modify columns. Count it as a partial success, please.

Option Explicit

Private Enum Nws                        ' worksheet navigation
    ' 280                               ' change values to address other rows/columns
    NwsFirstDataRow = 2
    NwsSerial = 1                       ' columns:
    NwsGoods
    NwsType
    NwsPR                               ' enums without assigned value
    NwsQty                              ' take the value of the previous + 1
    NwsTarget = 7                       ' 7 = column("G")
                                        ' leave 1 blank column between Tbl & NwsTarget
End Enum

Sub CreateSummary()
    ' 280

    Dim Ws      As Worksheet
    Dim Tbl     As Range                ' table of original data
    Dim Data    As Variant              ' value of Tbl
    Dim Target  As Range                ' result area
    Dim R       As Long                 ' loop counter: rows

    Set Ws = ThisWorkbook.Worksheets("Sheet1")          ' change name to suit
    Set Tbl = Ws.Range("A1").CurrentRegion.Offset(1)
    Data = Tbl.Resize(Tbl.Rows.Count - 1).Value

    Application.ScreenUpdating = False
    Set Target = Ws.Cells(1, NwsTarget).CurrentRegion.Offset(1)
    Target.ClearContents
    Tbl.Columns(NwsGoods).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Target.Cells(1), Unique:=True

    With Ws
        For R = NwsFirstDataRow To .Cells(.Rows.Count, NwsTarget).End(xlUp).Row
            .Cells(R, NwsTarget + NwsQty - 2).Value = WorksheetFunction.SumIfs( _
                                                      Tbl.Columns(NwsQty), _
                                                      Tbl.Columns(NwsGoods), _
                                                      .Cells(R, NwsTarget).Value)
            .Cells(R, NwsTarget + NwsType - 2).Value = CSVString(.Cells(R, NwsTarget).Value, NwsType, Data)
            .Cells(R, NwsTarget + NwsPR - 2).Value = CSVString(.Cells(R, NwsTarget).Value, NwsPR, Data)
        Next R
    End With
    Target.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

Private Function CSVString(ByVal Good As String, _
                           Clm As Nws, _
                           Data As Variant) As String
    ' 280

    Dim Spike   As String
    Dim Itm     As String
    Dim R       As Long             ' loop counter: data rows

    For R = 1 To UBound(Data)
        If Data(R, NwsGoods) = Good Then
            Itm = "," & Data(R, Clm) & ","
            If InStr(1, Spike, Itm, vbTextCompare) = 0 Then
                Spike = Spike & Itm
            End If
        End If
    Next R
    If Len(Spike) Then
        Spike = Mid(Spike, 2, Len(Spike) - 2)
        CSVString = Replace(Spike, ",,", ", ")
    End If
End Function

Note that the Enum, here at the top of the code, must always be at the top of the module in which you keep it, preceded only by Option Explicit and before any procedures. Also note that the function CSVString will exclude duplicates. I'm not sure if this is a requirement but I suppose it can't do any harm.