Преобразуйте столбцы с несколькими строками данных в строки с несколькими столбцами, удалив дублирующиеся ссылочные номера

Question

У меня есть набор данных, аналогичный приведенному ниже:

Пример данных

Я хотел бы преобразовать данные в несколько столбцов, в которых дублируются идентификаторы (столбец 1)удаляются, а все остальные данные объединяются в отдельные строки, разбитые по столбцам.

Я пробовал следующий код из другого потока:

Преобразование столбцов с несколькими строками данных в строки снесколько столбцов в Excel.

Однако это приводит к тому, что данные столбца два также консолидируются по столбцам, в которых есть дубликаты строк.

Например, приведенная выше таблица будет выглядеть как

Текущий результат

Мне нужно изменить код так, чтобы он удалял только дублированные данные в столбце 1 и распределял оставшиеся данные по столбцам.

Я быкак данные заканчиваются следующим образом:

Желаемый результат

Ниже приведен код, который я использую:

---

Sub ConsolidateRows_SpreadAcross()

Dim lastRow As Long, i As Long, j As Long
Dim colMatch As Variant, colConcat As Variant

application.ScreenUpdating = False 'disable ScreenUpdating to avoid screen flashes

lastRow = range("A" & Rows.Count).End(xlUp).Row 'get last row

For i = lastRow To 2 Step -1

    If Cells(i, 2) = Cells(i - 1, 2) Then
        range(Cells(i, 3), Cells(i, Columns.Count).End(xlToLeft)).Copy Cells(i - 1, Columns.Count).End(xlToLeft).Offset(, 1)
        Rows(i).Delete
    Else
        If Cells(i, 1) = Cells(i - 1, 1) Then
            range(Cells(i, 2), Cells(i, Columns.Count).End(xlToLeft)).Copy _
                Cells(i - 1, Columns.Count).End(xlToLeft).Offset(, 1)
            Rows(i).Delete
        End If
    End If

Next

application.ScreenUpdating = True 'reenable ScreenUpdating

End Sub

---

Любая помощь будет очень полезнаreciated.

Answer 1

При наличии данных в текущем порядке вам не нужно проверять столбец A и столбец B.

Sub ConsolidateRows_SpreadAcross()

    Dim i As Long, j As Long
    Dim colMatch As Variant, colConcat As Variant

    Application.ScreenUpdating = False 'disable ScreenUpdating to avoid screen flashes

    With Worksheets("sheet15")

        For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 2 Step -1

            If .Cells(i, 1) = Cells(i - 1, 1) Then
                .Range(.Cells(i, 3), .Cells(i, .Columns.Count).End(xlToLeft)).Copy _
                  Destination:=.Cells(i - 1, .Columns.Count).End(xlToLeft).Offset(0, 1)
                .Rows(i).Delete
            End If

        Next i

        .Cells(1, "C").Resize(1, .Cells(1, 1).CurrentRegion.Columns.Count - 2) = "data"

    End With

    Application.ScreenUpdating = True 'reenable ScreenUpdating

End Sub