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