Word VBA - Table 合并问题

Question

我有一个文档，其中有多个 table 行需要合并，但是一个特定的 table 导致合并的第一行出现问题，而其余行则没有问题。

这里是合并的代码，它找到一个唯一的字符串只包含在那个 table 中来识别 table 然后尝试合并它。

'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

和table格式如下（提供示例）Pre Merge：

这是我希望它们在合并后的样子（提供示例）结束 table 结果：

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

更新

代码独立运行，但是当 2 个单独的 table 的 2 个合并在同一个宏中时，组合代码运行但似乎只合并一个 table 并跳过下一个.

 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

根据您的问题描述和 table 描述，您似乎可以使用类似的东西：

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

Word VBA - Table 合并问题

Word VBA - Issue with Table Merging

windows

merge

vba

ms-word

ms-office