Excel 如何使用VBA连接多个列

假设我有这张桌子：

我想看看：

A后续行动来自：

为了添加更多的列，我无法理解这段代码。代码用于“名称、类型、食物”，但我需要添加“地点”和“日期”

Sub Test()

Dim lr As Long, x As Long
Dim arr As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

With Feuil1

    'Get last used row
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row

    'Get array
    arr = .Range("A2:C" & lr).Value

    'Loop through array
    For x = LBound(arr) To UBound(arr)
        If dict.Exists(arr(x, 1) & "|" & arr(x, 2)) Then
            dict(arr(x, 1) & "|" & arr(x, 2)) = Join(Array(dict(arr(x, 1) & "|" & arr(x, 2)), arr(x, 3)), ", ")
        Else
            dict(arr(x, 1) & "|" & arr(x, 2)) = arr(x, 3)
        End If
    Next x

    'Loop through dictionary
    For x = 0 To dict.Count - 1
        .Cells(x + 2, 8).Resize(, 2).Value = Split(dict.keys()(x), "|")
        .Cells(x + 2, 10).Value = dict.items()(x)
    Next x

End With

End Sub

一些相对“简单”的调整将使这项工作：

希望你能理解。你最初的问题中的不幸措辞也很好。不用担心

---

快乐编码

这里有一个通用函数，它将根据指定的“键”和“值”列返回数据表的摘要版本

（仅在此处发布，因为您的后续问题仍处于关闭状态：请不要在此处将此标记为答案）

子测试仪（）
暗淡的边缘
'汇总输入表
arr=summary（ActiveSheet.Range（“B2”）.CurrentRegion，数组（1,2,4），数组（3,5））
'将输出放在工作表上
ActiveSheet.Range（“h2”）.调整大小（UBound（arr，1），UBound（arr，2））。值=arr
端接头
'给定输入表rngData（包括标题），根据
'arrKeyCols中的“键”列，连接arrValueCols中的值
'注意：提供相对于输入范围而不是工作表的列号
'如果表以ColB开头，那么第一列是1，而不是2
函数汇总（rngData作为范围、arrKeyCols、arrValueCols）
Dim arr作为变型，arrOut，v
Dim dict作为对象，k，r作为长，r2，c作为长，rOut作为长
Set dict=CreateObject（“Scripting.Dictionary”）
arr=rngData.Value'Hi！是的，我问了另一个问题，但我想你不会再回答了，所以我补充了这个问题。这一个有点不同…就是这样。对不起，英语不是我的第一语言，我很难表达自己。我不是想说我是在这里以外的地方找到的，也不是想诋毁你@我做了一次编辑，删除了令人困惑的措辞，并将问题的链接移到顶部。不用担心。无论如何，你有理由提出另一个问题。不过，如果你能先根据自己的需要修改一下，那就最好了。非常感谢你，兄弟。上帝保佑你。
Sub Test()

Dim lr As Long, x As Long
Dim arr As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

With Sheet1

    'Get last used row
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row

    'Get array
    arr = .Range("A2:E" & lr).Value

    'Loop through array
    For x = LBound(arr) To UBound(arr)
        If dict.Exists(arr(x, 1) & "|" & arr(x, 2) & "$" & arr(x, 4) & "|" & arr(x, 5)) Then
            dict(arr(x, 1) & "|" & arr(x, 2) & "$" & arr(x, 4) & "|" & arr(x, 5)) = Join(Array(dict(arr(x, 1) & "|" & arr(x, 2) & "$" & arr(x, 4) & "|" & arr(x, 5)), arr(x, 3)), ", ")
        Else
            dict(arr(x, 1) & "|" & arr(x, 2) & "$" & arr(x, 4) & "|" & arr(x, 5)) = arr(x, 3)
        End If
    Next x

    'Loop through dictionary
    For x = 0 To dict.Count - 1
        .Cells(x + 2, 6).Resize(, 2).Value = Split(Split(dict.keys()(x), "$")(0), "|")
        .Cells(x + 2, 8).Value = dict.items()(x)
        .Cells(x + 2, 9).Resize(, 2).Value = Split(Split(dict.keys()(x), "$")(1), "|")
    Next x

End With

End Sub

Sub Tester()

    Dim arr
    'summarize the input table
    arr = Summarize(ActiveSheet.Range("B2").CurrentRegion, Array(1, 2, 4), Array(3, 5))
    'put the output on the sheet
    ActiveSheet.Range("h2").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

End Sub



'Given an input table rngData (incl. headers), summarize according to
'  the "key" columns in arrKeyCols, concatenating values in arrValueCols
' Note: supply column numbers relative to the input range, not the worksheet
'    If your table starts in ColB, then the first column is 1, not 2
Function Summarize(rngData As Range, arrKeyCols, arrValueCols)

    Dim arr As Variant, arrOut, v
    Dim dict As Object, k, r As Long, r2, c As Long, rOut As Long

    Set dict = CreateObject("Scripting.Dictionary")

    arr = rngData.Value '<< input data, including headers

    'Size the output array and copy the headers
    '  Might have empty "rows" at the end but that's not worth fixing
    '  given the possible case where no input rows share the same "key"
    ReDim arrOut(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    For c = 1 To UBound(arr, 2)
        arrOut(1, c) = arr(1, c)
    Next c

    rOut = 2 'start populating output array on this "row"

    'loop over the input data
    For r = 2 To UBound(arr, 1)

        'build the "key" for this row from the key columns passed in arrKeyCols
        k = ""
        For c = 0 To UBound(arrKeyCols)
            k = k & IIf(c > 0, Chr(0), "") & arr(r, arrKeyCols(c))
        Next c

        'Find the matching row in the output array: if it doesn't exist then create it
        If Not dict.exists(k) Then
            dict(k) = rOut  '<< associate the key with a row in the output array
            'populate the key columns in the output array
            For c = 0 To UBound(arrKeyCols)
                arrOut(rOut, arrKeyCols(c)) = arr(r, arrKeyCols(c))
            Next c
            r2 = rOut
            rOut = rOut + 1 '<< for the next new key
        End If

        r2 = dict(k) '<< use this row for populating "values" columns

        'build the "value" column(s) from arrValueCols
        For c = 0 To UBound(arrValueCols)
            v = arrOut(r2, arrValueCols(c)) 'extract the existing value
            v = v & IIf(Len(v) > 0, ",", "") & arr(r, arrValueCols(c))
            arrOut(r2, arrValueCols(c)) = v 're-add the appended value
        Next c

    Next r

    Summarize = arrOut
End Function