Как объединить несколько столбцов с помощью VBA

Question

Допустим, у меня есть эта таблица:

Я хотел бы видеть:

Ответ от на этот вопрос :

Я не могу понять этот код, чтобы добавить больше столбцов. Код работает для «Name, Type, Food», но мне нужно добавить «Place» и «date».

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

Answer 1

Вот обобщенная функция c, которая будет возвращать итоговую версию таблицы данных в соответствии с указанными столбцами «ключ» и «значение».

(размещено здесь только как ваш дополнительный вопрос закрыт (просьба не отмечать это как ответ)

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

Answer 2

Некоторые относительные «простые» настройки могли бы сделать эту работу:

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

Надеюсь, вы сможете понять. И все хорошо о неудачной формулировке в вашем оригинальном вопросе. Не беспокойтесь.

Счастливое кодирование