Объединение строчек опираясь на другой столбец

[Morozeckiy]

Добрый вечер, товарищи. Ищу помощи в дополнении к макросу.
Файл с примером в приложении. Суть такова:
В файле 2 колонки. в первом столбце идет порядковый номер объекта в объеденной ячейке, которая равна кол-ву ячеек второго столбца. Во втором столбце идет построчно информация, которая соответствует объекту в ячейке первого столбца.
Необходимо объеденить ячейки второго столбца, которые принадлежат объекту первого столбца. То есть, где то их 3 строки, где то 10, а где то и одна, которую нужно пропустить.

На данный момент выручает такой макрос
Sub MergeToOneCell()
* *Const sDELIM As String = ", " * * 'символ-разделитель
* *Dim rCell As Range
* *Dim sMergeStr As String
* *If TypeName(Selection) <> "Range" Then Exit Sub * 'если выделены не ячейки - выходим
* *With Selection
* * * *For Each rCell In .Cells
* * * * * *sMergeStr = sMergeStr & sDELIM & rCell.Text *'собираем текст из ячеек
* * * *Next rCell
* * * *Application.DisplayAlerts = False * 'отключаем стандартное предупреждение о потере текста
* * * *.Merge Across:=False * * * * * * * *'объединяем ячейки
* * * *Application.DisplayAlerts = True
* * * *.Item(1).Value = Mid(sMergeStr, 1 + Len(sDELIM)) * *'добавляем к объед.ячейке суммарный текст
* *End With
End Sub

Им я могу объединять ячейки в ручную без потери текста, но строк 3500. Можно ли в этот макрос вставить еще одно условие, для ориентира на первый столбец?

Спасибо за внимание.пример.xlsx

[SAS888]

Можно так:

Sub Main()
    Dim i As Long, j As Integer, s As String, cell As Range
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    [B:B].WrapText = True: i = 2
    Do While Cells(i, 1) <> ""
        j = Cells(i, 1).MergeArea.Cells.Count
        If j > 1 Then
            For Each cell In Cells(i, 1).MergeArea
                If cell.Offset(, 1) <> "" Then s = s & cell.Offset(, 1) & ", "
            Next
            Cells(i, 2).Resize(j).Merge: Cells(i, 2) = Left$(s, Len(s) - 2)
        End If
        i = i + j: s = ""
    Loop
End Sub

Пример во вложении.

[Morozeckiy]

Сообщение от SAS888

Можно так:

Sub Main()
    Dim i As Long, j As Integer, s As String, cell As Range
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    [B:B].WrapText = True: i = 2
    Do While Cells(i, 1) <> ""
        j = Cells(i, 1).MergeArea.Cells.Count
        If j > 1 Then
            For Each cell In Cells(i, 1).MergeArea
                If cell.Offset(, 1) <> "" Then s = s & cell.Offset(, 1) & ", "
            Next
            Cells(i, 2).Resize(j).Merge: Cells(i, 2) = Left$(s, Len(s) - 2)
        End If
        i = i + j: s = ""
    Loop
End Sub

Пример во вложении.

Спасибо тебе, добрый человек. Вопрос решен за секунду. Спасибо!