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

表格式如下（提供样本）Pre Merge：

以下是我希望它们在合并后的结果（提供样本）结束表结果：

正如我所提到的，此合并的代码适用于所有其他表，但不是这个。有什么想法吗？

更新

代码正在自行运行但是当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