Объедините несколько строк в один

Question

Я пытаюсь объединить несколько строк данных в одну. Столбец A содержит значение, на котором будут основываться группировки - строки, значения которых соответствуют столбцу A, будут объединены в одну строку. Мой диапазон простирается от столбца A до X, поэтому мне нужен соответствующий ряд данных для начала в столбце Y.

Пример:

╔══════╦═══╦═══╗
║ 1001 ║ A ║ C ║
║ 1001 ║ B ║ D ║
║ 1002 ║ A ║ E ║
║ 1002 ║ B ║ F ║
║ 1002 ║ C ║ G ║
╚══════╩═══╩═══╝

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

╔══════╦═══╦═══╦═══╦═══╦═══╦═══╗
║ 1001 ║ A ║ C ║ B ║ D ║   ║   ║
║ 1002 ║ A ║ E ║ B ║ F ║ C ║ G ║
╚══════╩═══╩═══╩═══╩═══╩═══╩═══╝

Код VBA, который я сейчас использую, не принимает все содержимое совпадающей строки. Он только берет данные во 2-м столбце и перемещает их вверх.

Код VBA:

Sub Mergeitems()

    Dim cl As Range
    Dim rw As Range

    Set rw = ActiveCell

    Do While rw <> ""
        ' for each row in data set
        '   find first empty cell on row
        Set cl = rw.Offset(0, 1)
        Do While cl <> ""
            Set cl = cl.Offset(0, 1)
        Loop

        ' if next row needs to be processed...
        Do While rw = rw.Offset(1, 0)
            cl = rw.Offset(1, 1)       ' move the data
            Set cl = cl.Offset(0, 1)   ' update pointer to next blank cell
            rw.Offset(1, 0).EntireRow.Delete xlShiftUp   ' delete old data
        Loop

        ' next row
        Set rw = rw.Offset(1, 0)
    Loop
End Sub

Answer 1

Возможно, я бы подошел к вашей общей проблеме (объединению строк) с совершенно другим макросом, но вот строки, которые вы, возможно, захотите изменить в своем коде:

cl = rw.Offset(1, 1)       ' move the data
Set cl = cl.Offset(0, 1)   ' update pointer to next blank cell
rw.Offset(1, 0).EntireRow.Delete xlShiftUp   ' delete old data

Попробуйте заменить их на это:

i = 1
Do While rw.Offset(1, i) <> "" 
    cl = rw.Offset(1, i)      
    Set cl = cl.Offset(0, 1)  
    i = i + 1
Loop
rw.Offset(1, 0).EntireRow.Delete xlShiftUp  'delete old data

Результат: