在唯一标识符上合并行而不消除唯一数据并一起添加值

Question

我有一个很大的Excel电子表格，我需要在唯一标识符上合并行。我正在尝试开发一个Excel VBA宏，但仍缺乏解决这个问题的熟练程度。

这是我正在尝试做的一个例子的图片。包含标题的数据都是为示例而制作的，但下面演示的正是我正在尝试做的事情。

实施例

之前：

Unique ID | Item Name | Item Description | Numbers Sold | Notes
11111     | Cupcakes  | Red              | 10           | Good
11111     | Cupcakes  | Red              | 15           | Testing
11111     | Cupcakes  | Red              | 10           | Bad
22222     | Brownies  | Brown            | 11           | Example
22222     | Brownies  | Brown            | 11           | Example2
22222     | Brownies  | Brown            | 26           | Example3

后：

Unique ID | Item Name | Item Description | Numbers Sold | Notes
11111     | Cupcakes  | Red              | 35           | Good, Testing, Bad
22222     | Brownies  | Brown            | 37           | Example, Example 2, Example 3

如您所见，类似数据基于唯一ID在前3列合并在一起。包含数字值的第4列将相加。第5列中的任何唯一值都作为唯一数据保存在一起。

我很感激任何人都能给我的帮助或提示。谢谢！

Answer 1

好吧，好吧， 视觉呈现。

设置表1

设置表2

向工作表1添加按钮

通过按Ctrl键转到VBA编辑器＆amp; F11或使用开发人员功能区

插入模块

复制并粘贴此代码

Sub GetUnique()
    Dim cUnique As Collection
    Dim Rng As Range
    Dim Cell As Range
    Dim sh As Worksheet
    Dim vNum As Variant

    Set sh = ThisWorkbook.Sheets("Sheet1")
    Set Rng = sh.Range("A2", sh.Range("A2").End(xlDown))
    Set cUnique = New Collection

    On Error Resume Next
    For Each Cell In Rng.Cells
        cUnique.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    On Error GoTo 0

    For Each vNum In cUnique
        Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = vNum
    Next vNum
    FiltDat
End Sub
Sub FiltDat()
    Dim ws As Worksheet
    Dim sh As Worksheet
    Dim Rws As Long, Rng As Range, Sm As Range, c As Range
    Dim fRws As Long, fRng As Range, fc As Range, fx As String, cma
    Rws = Cells(Rows.Count, "A").End(xlUp).Row - 9
    Set ws = Worksheets("Sheet1")
    Set sh = Worksheets("Sheet2")
    Application.ScreenUpdating = 0
    With sh
        Rws = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng = .Range(.Cells(2, 1), .Cells(Rws, 1))
    End With
    For Each c In Rng.Cells
        With ws
            .Range("A:A").AutoFilter Field:=1, Criteria1:=c
            Set Sm = .Columns("D:D").SpecialCells(xlCellTypeConstants, 1)
            c.Offset(0, 3) = Application.Sum(Sm.SpecialCells(xlCellTypeVisible))
            fRws = .Cells(Rows.Count, "E").End(xlUp).Row
            Set fRng = .Range(.Cells(2, "E"), .Cells(fRws, "E")).SpecialCells(xlCellTypeVisible)
            cx = fRng.Rows.Count
            fx = ""
            y = 1
            For Each fc In fRng.Cells
                cma = IIf(y <> cx, ",", "")
                fx = fx & fc & cma
                y = y + 1
                c.Offset(, 1) = fc.Offset(0, -3)
                c.Offset(, 2) = fc.Offset(0, -2)

            Next fc
            c.Offset(0, 4) = fx
            .AutoFilterMode = 0
        End With
    Next c
End Sub

退出VBA编辑器并将宏指定给按钮，指定GetUnique宏

单击按钮并转到工作表2以查看结果。