CODEWITHSUNDEEP
windowsvbamergems-wordms-office
Aaron
Aaron

Reputation: 35

Word VBA - Issue with Table Merging

I have a document with several tables with rows that require merging, however one specific table is causing issues failing on the first row of the merge while the rest have no issues.

Here is the code for the merge, it finds a unique string only contained within that one table to identify the table and then attempts to merge it. 

'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

And table format is the following (sample provided) Pre Merge:

enter image description here

Here is how I would like them to be after the merge (sample provided) End table result:

enter image description here

As I had mentioned, the code for this merge works with every other table, however not this one. Any ideas why?

Update

The code is working on its own but when 2 merges for 2 separate tables are in the same macro, the combined code runs but only seems to merge one table and skips the next.

 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

Upvotes: 0

Views: 1338

Answers (1)

macropod
macropod

Reputation: 13505

From your problem description and table depictions it appears you could use something like:

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

Upvotes: 1

Related Questions