Word VBA - проблема с объединением таблиц

Question

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

Вот код дляобъединение, он находит уникальную строку, содержащуюся только в этой таблице, чтобы идентифицировать таблицу, а затем пытается объединить ее.

'Merge Table
With Selection.Find
    .ClearFormatting
    .Text = "Unique String"
    .Execute
End With

'If this selection is in the table

If Selection.Information(wdWithInTable) Then
    With Selection.Tables(1)
        'First row of merges
        .Cell(Row:=2, Column:=1).Merge _ 'Here is where the merge throws an error "The requested member of the collection does not exist"
        MergeTo:=.Cell(Row:=3, Column:=1)
        .Cell(Row:=2, Column:=3).Merge _
        MergeTo:=.Cell(Row:=3, Column:=3)
        .Cell(Row:=2, Column:=4).Merge _
        MergeTo:=.Cell(Row:=3, Column:=4)
        .Cell(Row:=2, Column:=5).Merge _
        MergeTo:=.Cell(Row:=3, Column:=5)

        'Second row of merges
        .Cell(Row:=4, Column:=1).Merge _
        MergeTo:=.Cell(Row:=5, Column:=1)
        .Cell(Row:=4, Column:=3).Merge _
        MergeTo:=.Cell(Row:=5, Column:=3)
        .Cell(Row:=4, Column:=4).Merge _
        MergeTo:=.Cell(Row:=5, Column:=4)
        .Cell(Row:=4, Column:=5).Merge _
        MergeTo:=.Cell(Row:=5, Column:=5)

        'More merges here
    End With
End If

И формат таблицы следующий (образец предоставлен). Предварительное слияние:

Вот как я бы их хотелбыть после слияния (образец предоставлен) Результат конечной таблицы:

Как я уже упоминал, код для этого слияния работает с любой другой таблицей,однако не этот.Есть идеи, почему?

Обновление

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

 With Selection.Find
    .ClearFormatting
    .Text = "Unique String 1"
    .Execute
End With

'If this selection is in the Table

If Selection.Information(wdWithInTable) Then
    With Selection.Tables(1)
        .Cell(Row:=2, Column:=1).Merge _
        MergeTo:=.Cell(Row:=5, Column:=1)
        .Cell(Row:=6, Column:=1).Merge _
        MergeTo:=.Cell(Row:=7, Column:=1)
        .Cell(Row:=8, Column:=1).Merge _
        MergeTo:=.Cell(Row:=10, Column:=1)
        .Cell(Row:=12, Column:=1).Merge _
        MergeTo:=.Cell(Row:=15, Column:=1)
        .Cell(Row:=16, Column:=1).Merge _
        MergeTo:=.Cell(Row:=18, Column:=1)
    End With
End If

    'Merge Table
With Selection.Find
    .ClearFormatting
    .Text = "Unique String 2"
    .Execute
End With

'If this selection is in the table

If Selection.Information(wdWithInTable) Then
    With Selection.Tables(1)
        'First row of merges
        .Cell(Row:=2, Column:=1).Merge _ 'Here is where the merge throws an error "The requested member of the collection does not exist"
        MergeTo:=.Cell(Row:=3, Column:=1)
        .Cell(Row:=2, Column:=3).Merge _
        MergeTo:=.Cell(Row:=3, Column:=3)
        .Cell(Row:=2, Column:=4).Merge _
        MergeTo:=.Cell(Row:=3, Column:=4)
        .Cell(Row:=2, Column:=5).Merge _
        MergeTo:=.Cell(Row:=3, Column:=5)

        'Second row of merges
        .Cell(Row:=4, Column:=1).Merge _
        MergeTo:=.Cell(Row:=5, Column:=1)
        .Cell(Row:=4, Column:=3).Merge _
        MergeTo:=.Cell(Row:=5, Column:=3)
        .Cell(Row:=4, Column:=4).Merge _
        MergeTo:=.Cell(Row:=5, Column:=4)
        .Cell(Row:=4, Column:=5).Merge _
        MergeTo:=.Cell(Row:=5, Column:=5)

        'More merges here
    End With
End If

Answer 1

Из описания вашей проблемы и из таблиц видно, что вы можете использовать что-то вроде:

Sub Demo()
Application.ScreenUpdating = False
Call TblProcessor("Unique String 1")
Call TblProcessor("Unique String 2")
Application.ScreenUpdating = True
End Sub

Sub TblProcessor(StrFnd As String)
Dim c As Long, r As Long, i As Long
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = StrFnd
    .Format = False
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found = True
    If .Information(wdWithInTable) = True Then
      With .Tables(1)
        For i = .Range.Cells.Count To 1 Step -1
          With .Range.Cells(i)
            r = .RowIndex: c = .ColumnIndex
          End With
          If r < 3 Then Exit For
          If Split(.Cell(r, c).Range.Text, vbCr)(0) = "" Then
            .Cell(r - 1, c).Merge MergeTo:=.Cell(r, c)
          End If
        Next
      End With
      .End = .Tables(1).Range.End
    End If
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
End Sub