Конкатенация, основанная на условии

Question

Я пытаюсь использовать VB для конкатенации на основе дубликатов первого столбца в Excel. Ниже приведен пример оригинала.

Apple     Polar      Purple     Dry
Apple     Brown      Blue       Wet
Apple     Kodiac     Yellow     Cold
Pear      Panda      Green      Hot
Pear      Black      Orange     Warm

Это то, чего я пытаюсь достичь

Apple     Polar Brown Kodiac      Purple Blue Yellow      Dry Wet cold
Pear      Panda Black             Green Orange            Hot Warm 

Я пытаюсь использовать следующее руководство https://www.extendoffice.com/documents/excel/3153-excel-concatenate-if-same-value.html

Это пример кода, который они дают, который изменяет только первые два столбца.

Sub ConcatenateCellsIfSameValues()
Dim xCol As New Collection
Dim xSrc As Variant
Dim xRes() As Variant
Dim I As Long
Dim J As Long
Dim xRg As Range
xSrc    = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(, 2)
Set xRg = Range("D1")
On Error Resume Next
For I = 2 To UBound(xSrc)
    xCol.Add xSrc(I, 1), TypeName(xSrc(I, 1)) & CStr(xSrc(I, 1))
Next I
On Error GoTo 0
ReDim xRes(1 To xCol.Count + 1, 1 To 2)
xRes(1, 1) = "No"
xRes(1, 2) = "Combined Color"
For I = 1 To xCol.Count
    xRes(I + 1, 1) = xCol(I)
    For J = 2 To UBound(xSrc)
        If xSrc(J, 1) = xRes(I + 1, 1) Then
            xRes(I + 1, 2) = xRes(I + 1, 2) & ", " & xSrc(J, 2)
        End If
    Next J
    xRes(I + 1, 2) = Mid(xRes(I + 1, 2), 2)
Next I
Set xRg = xRg.Resize(UBound(xRes, 1), UBound(xRes, 2))
xRg.NumberFormat = "@"
xRg = xRes
xRg.EntireColumn.AutoFit
End Sub

Это то, что я тоже пытаюсь изменить

Sub ConcatenateCellsIfSameValues()
Dim xCol As New Collection
Dim xSrc As Variant
Dim xRes() As Variant
Dim I As Long
Dim J As Long
Dim P As Long
Dim D As Long
Dim xRg As Range
xSrc = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(, 2)
Set xRg = Range("E1")
On Error Resume Next
For I = 2 To UBound(xSrc)
    xCol.Add xSrc(I, 1), TypeName(xSrc(I, 1)) & CStr(xSrc(I, 1))
Next I
On Error GoTo 0
ReDim xRes(1 To xCol.Count + 1, 1 To 2)
xRes(1, 1) = "Vulnerability"
xRes(1, 2) = "Risk"
xRes(1, 3) = "IP"
xRes(1, 4) = "DNS Name"
For I = 1 To xCol.Count
    xRes(I + 1, 1) = xCol(I)
    For J = 2 To UBound(xSrc)
        If xSrc(J, 1) = xRes(I + 1, 1) Then
            xRes(I + 1, 2) = xRes(I + 1, 2) & ", " & xSrc(J, 2)
    For P = 3 To UBound(xSrc)
        If xSrc(P, 1) = xRes(I + 1, 1) Then
            xRes(I + 1, 3) = xRes(I + 1, 3) & ", " & xSrc(P, 3)
    For D = 4 To UBound(xSrc)
        If xSrc(D, 1) = xRes(I + 1, 1) Then
            xRes(I + 1, 4) = xRes(I + 1, 4) & ", " & xSrc(D, 4)
        End If
    Next D
    xRes(I + 1, 2) = Mid(xRes(I + 1, 2), 2)
    End If
Next I
Set xRg = xRg.Resize(UBound(xRes, 1), UBound(xRes, 2))
xRg.NumberFormat = "@"
xRg = xRes
xRg.EntireColumn.AutoFit
End Sub

Answer 1

Попробуйте

Sub ConcatenateCellsIfSameValues()
Dim xCol As New Collection
Dim xSrc As Variant
Dim xRes() As Variant
Dim I As Long
Dim J As Long
Dim k As Long
Dim xRg As Range

    'xSrc = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(, 2)
    xSrc = Range("a1").CurrentRegion

    Set xRg = Range("E1")

    On Error Resume Next
    For I = 2 To UBound(xSrc)
        xCol.Add xSrc(I, 1), TypeName(xSrc(I, 1)) & CStr(xSrc(I, 1))
    Next I

    On Error GoTo 0

    ReDim xRes(1 To xCol.Count + 1, 1 To 4)
    xRes(1, 1) = "Vulnerability"
    xRes(1, 2) = "Risk"
    xRes(1, 3) = "IP"
    xRes(1, 4) = "DNS Name"


    For I = 1 To xCol.Count
        xRes(I + 1, 1) = xCol(I)
        For J = 2 To UBound(xSrc)
            If xSrc(J, 1) = xCol(I) Then
                For k = 2 To 4
                    If xRes(I + 1, k) = "" Then
                        xRes(I + 1, k) = xSrc(J, k)
                    Else
                        xRes(I + 1, k) = xRes(I + 1, k) & ", " & xSrc(J, k)
                    End If
                Next k
            End If
        Next J
    Next I

    Set xRg = xRg.Resize(UBound(xRes, 1), UBound(xRes, 2))
    xRg.NumberFormat = "@"
    xRg = xRes
    xRg.EntireColumn.AutoFit
End Sub