Combining 2 tables into 1 and use Table2's column widths (hoping for workaround dealing merged cells

[CodingGuruInTraining]

Hello,

I am trying to create a Word macro that will adjust every table in a document to have specific column widths. These documents I work with can vary anywhere from 15 pages to 1000 pages with varying table lengths, but always with 4 columns. The problem is there are merged cells (both vertical and horizontal) in each table and they are needed for this project, so they have to stay. I have been searching for days, but I have not been able to find a code that truly works around this issue.

Since it looks like VBA can't modify a table with merged cells, I thought it might be possible to make a new table the way I want it formatted and then combine that with a table in the document. Is it possible to create a macro that can perform the following actions and if so, how would it look in VBA:



1) Find table (Table1)
2) Add new 1x4 table (Table2) above (or below if it matters) Table1 with desired column widths
' this would basically be a copy header row found on every table in document
3) Combine (snap together) Table1 and Table2, using Table2's column widths
' if not possible, then perhaps Table2's "table width" will work
4) Delete 2nd row (formerly 1st row) in each table
5) Next table

Any advice would be appreciated!

[macropod]

Working with horizontally merged cells means you'd probably have to loop through all cells and explicitly set their widths, one cell at a time. That also means you'll need to test each cell's width to work out whether it's too wide to fit a single column and, if so, how many columns it spans - simply testing the column index of the next cell on the row won't work, since that's always one more than the current one. This isn't too hard if the existing tables have a consistent layout but, if the column widths are all over the place (especially if the same nominal column has more than one width in an existing table), your code will also need to do some testing to work out what the current nominal column widths are - and that's made all the more difficult if auto-resizing is on.

[CodingGuruInTraining]

Thanks for your reply! The tables I am working with should follow a set criteria, but they are often slightly different and sometimes drastically different (unfortunately). The standard layout contains 3 rows:
Row 1 = repeating title row
Row 2 = column 1 vertically merged with row 3; criteria in columns 2-4
Row 3 = column 1 vertically merged with row 2; column 2-4 horizontally merged
I'm attaching an example for a visual.

Below are some attempts I've made. Note that they're not all complete and I know they don't work with merged cells. Do any of these attempts look promising for what I am trying to do?

PHP Code:

Sub TableFormat()
'
' 
'
'

Dim oCell As Cell
Dim oTable As Table
Dim oRow As Row
Dim oColm As Column

''attempt 1 below
For Each oTable In ActiveDocument.Tables
    oTable.Rows.Height = InchesToPoints(1.5)
    oTable.AutoFitBehavior wdAutoFitFixed
    oTable.Columns.Width = InchesToPoints(2.3)
Next oTable
'tried changing all columns to same width first to make updates easier

For Each oTable In ActiveDocument.Tables
    For Each oCell In oTable.Columns
    With oCell
        oCell.Cells(1).Width = InchesToPoints(0.45)
        If oRow.Cells.Count = 2 Then
            oRow.Cells(2).Width = InchesToPoints(6.2)
        ElseIf oRow.Cells.Count = 4 Then
            oRow.Cells(2).Width = InchesToPoints(1.5)
            oRow.Cells(3).Width = InchesToPoints(2.38)
            oRow.Cells(4).Width = InchesToPoints(2.33)
        Else
        End If
    End With
    Next oCell
Next oTable

''attempt 2 below
For Each oTable In ActiveDocument.Tables
    oTable.Columns(1).Width = InchesToPoints(0.45)         
    oTable.Columns(2).Width = InchesToPoints(1.5)
    oTable.Columns(3).Width = InchesToPoints(2.38)
    oTable.Columns(4).Width = InchesToPoints(2.33)
    For Each oRow In oTable.Rows
        If oRow.Cells.Count = 2 Then
            oRow.Cells(2).Width = InchesToPoints(6.2)
        End If
        Next oRow
Next oTable

''attempt 3 below
For Each oTable In ActiveDocument.Tables
    With oTable.Columns(1)
        .Width = InchesToPoints(0.45)
    End With

''attempt 4 below
For Each oTable In ActiveDocument.Tables
    With oTable.Rows(1)
        If oCell.ColumnIndex = 1 Then
            oCell.Width = InchesToPoints(0.45)
        End If
    End With
Next oTable

''attempt 5 below
For Each oTable In ActiveDocument.Tables
   .Tables .Cell(1, 1).Width = InchesToPoints(0.45)
Next oTable

''attempt 6 below
For Each oCell In ActiveDocument.Tables
    With oCell(1, 1) = True
        .Width = InchesToPoints(0.45)
    End With
Next oCell

End Sub 


[macropod]

The table image in your post depicts a 5-row * 4-column table. By how much do the non-standard tables differ from that table's structure?

[CodingGuruInTraining]

My apologies; I didn't explain that very well. Each table will have a title row followed by any number of additional rows, but they will always follow that design where there are 4 cells in one row and then a merged cell underneath (this is the "standard" part I was referring to). The image I attached is showing 2 occurrences.

[macropod]

OK but, after the title row, do they all have the same structure (i.e. a pair of rows consisting of a merged cell spanning two rows on the left and the lower row of the pair merged across cells 2-4)?

[CodingGuruInTraining]

Yes, that is correct.

[macropod]

Try the following macro for creating the new tables. They'll appear after the existing ones.

Sub Demo()
Dim wdDoc As Document, Tbl As Table, Rng As Range, i As Long, j As Long, k As Long
Application.ScreenUpdating = False
Set wdDoc = ActiveDocument
With wdDoc
  For i = .Tables.Count To 1 Step -1
    With .Tables(i).Range
      j = (.Cells(.Cells.Count).RowIndex - 1) / 2
      .Paragraphs.Last.Next.Range.InsertBefore vbCr & vbCr & vbCr & vbCr
      Set Rng = .Paragraphs.Last.Next.Next.Range
      Rng.Collapse wdCollapseStart
      Set Tbl = wdDoc.Tables.Add(Range:=Rng, NumRows:=2, NumColumns:=4, AutoFitBehavior:=False)
      With Tbl
        .Borders.Enable = True
        .Rows.HeightRule = wdRowHeightExactly
        .Rows(1).Height = InchesToPoints(0.25)
        .Rows(2).Height = InchesToPoints(0.5)
        .Cell(2, 1).VerticalAlignment = wdCellAlignVerticalCenter
        .Columns.PreferredWidthType = wdPreferredWidthPoints
        .Rows(1).Shading.BackgroundPatternColorIndex = wdTurquoise
        .Columns(1).Shading.BackgroundPatternColorIndex = wdTurquoise
        .Columns(1).Width = InchesToPoints(0.45)
        .Columns(2).Width = InchesToPoints(1.5)
        .Columns(3).Width = InchesToPoints(2.38)
        .Columns(4).Width = InchesToPoints(2.33)
        Set Rng = .Range
        With Rng
          .SetRange Start:=.Cells(6).Range.Start, End:=.Cells(8).Range.End
          .Cells.Split NumRows:=2, NumColumns:=1, MergeBeforeSplit:=False
          .Rows.HeightRule = wdRowHeightExactly
          .Cells.Height = InchesToPoints(0.25)
          .SetRange Start:=Tbl.Range.Cells(9).Range.Start, End:=Tbl.Range.End
          .Cells.Merge
          .SetRange Start:=Tbl.Range.Cells(5).Range.Start, End:=Tbl.Range.End
          .Copy
        End With
        For k = 2 To j
          With .Range.Paragraphs.Last.Next.Range
            .InsertBefore vbCr
            .Paste
          End With
        Next
      End With
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub

[CodingGuruInTraining]

Wow that is impressive! I take it there's no easier way than to create new tables, correct? If that is the case, is there a way to copy or cut the content from the original table, paste into the new table, and then delete the original?

[macropod]

Originally Posted by CodingGuruInTraining

Wow that is impressive! I take it there's no easier way than to create new tables, correct?

The basic table's creation (i.e. header row plus the two rows below that) is only part of what the code does. It then has to replicate as many of the non-header rows as are necessary to match the original table. An alternative, if your existing tables (which I haven't seen) were suitable, would be to forego creating a new table and just re-format the existing ones.

Originally Posted by CodingGuruInTraining

If that is the case, is there a way to copy or cut the content from the original table, paste into the new table, and then delete the original?

Yes, that's quite easily done. I just wanted to check whether the basic table creation was doing the right thing first. If you can confirm that, I'll look at adding the rest.

[CodingGuruInTraining]

The basic table's creation (i.e. header row plus the two rows below that) is only part of what the code does. It then has to replicate as many of the non-header rows as are necessary to match the original table. An alternative, if your existing tables (which I haven't seen) were suitable, would be to forego creating a new table and just re-format the existing ones.

I was referring to my original strategy, although I was doubtful whether such a method was possible. Unfortunately, the merged cells prevent formatting the current tables unless there is a workaround that I have not come across yet. If this way works, then that is all that matters really.

I tried your code yesterday and it worked great on the tables, but it seems to paste over 5-6 lines of text inbetween tables. I am still trying to figure out how your code works, but I'm wondering if this issue has something to do with the following part:

With .Range.Paragraphs.Last.Next.Range
            .InsertBefore vbCr

In one affected part I removed an extra line and then ran the code, which removed all remaining text (more than the 5-6 lines) between these 2 tables.
In another part, removing an indent/tab on a line under a table removed 2 more lines than before. I am still playing around with other causes, but hopefully you know more about this cause than I do.

[macropod]

Originally Posted by CodingGuruInTraining

I was referring to my original strategy, although I was doubtful whether such a method was possible. Unfortunately, the merged cells prevent formatting the current tables unless there is a workaround that I have not come across yet. If this way works, then that is all that matters really.

Sure it's possible to reformat tables with merged cells and doing so would obviate all the circumlocution the current approach will require. But, without seeing some representative sample tables (even without data), I don't know what the better course is. Hint...

Originally Posted by CodingGuruInTraining

I tried your code yesterday and it worked great on the tables, but it seems to paste over 5-6 lines of text inbetween tables.

That's because I took the precaution of inserting extra blank paragraphs in case there were consecutive tables in the document - you wouldn't want them getting joined up. Any redundant empty paragraphs can be cleaned up later.

[CodingGuruInTraining]

That is good to hear! I think a sample might help so I put one together and attached it here. Hopefully it provides what you need.

[macropod]

Try:

Sub Demo()
Application.ScreenUpdating = False
Dim wdDoc As Document, Tbl As Table, sWdth(), i As Long, Rng As Range
'Store all the widths used. 1st item = table width
'2nd - 5th items = individual cell widths
'6th item = sum of of 3rd - 5th items
sWdth = Array(6.66, 0.45, 1.5, 2.38, 2.33, 6.21)
Set wdDoc = ActiveDocument
With wdDoc
  For Each Tbl In .Tables
    With Tbl
      'Give the cells an all-round interior padding
      .TopPadding = InchesToPoints(0.05)
      .BottomPadding = InchesToPoints(0.05)
      .LeftPadding = InchesToPoints(0.05)
      .RightPadding = InchesToPoints(0.05)
      .Spacing = 0
      'Switch off autofit
      .AllowAutoFit = False
      'set the preferred width type
      .PreferredWidthType = wdPreferredWidthPoints
      'set the preferred width value to the specified array value
      .PreferredWidth = InchesToPoints(sWdth(0))
      With .Rows
        'Remove any table indenting
        .LeftIndent = 0
        'Center the table on the page
        .Alignment = wdAlignRowCenter
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
        'Give the cells automatic heights, so they'll fit their contents
        .HeightRule = wdRowHeightAuto
      End With
      With .Range
        'Ensure the first row functions as a heading row
        .Cells(1).Select: Selection.Rows.HeadingFormat = True
        'Format the first four cells
        For i = 1 To 4
          .Cells(i).Width = InchesToPoints(sWdth(i))
        Next
        'Format the remaining cells, in groups of 5.
        'The first cell in each group spans two rows and
        'the first row in each group contains 4 cells but
        'the second row contains 1 cell spanning the width
        'of the last 3 cells of the first row
        For i = 5 To .Cells.Count
          'If it's the first cell in a group, ensure it's both merged and centred vertically
          If ((i Mod 5) + 1) = 1 Then
            If .Cells(i + 4).ColumnIndex = 1 Then
              Set Rng = .Cells(i).Range
              Rng.End = .Cells(i + 4).Range.End
              Rng.Select: Selection.Cells.Merge
            End If
            .Cells(i).VerticalAlignment = wdCellAlignVerticalCenter
          End If
          'Specify a minimum height for the last cell in the group
          If ((i Mod 5) + 1) = 5 Then
            .Cells(i).SetHeight Rowheight:=InchesToPoints(0.5), HeightRule:=wdRowHeightAtLeast
          End If
          .Cells(i).Width = InchesToPoints(sWdth((i Mod 5) + 1))
          'If we've merged any cells, the count will have changed
          If i = .Cells.Count Then Exit For
        Next
      End With
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub

I don't know what you want to do about row heights, since setting them to a fixed size could compromise the display of their content, so I've just made their heights automatic, except for the last cell in each group, which has a minimum specified height, so that all cells will fit whatever content is there. I've also applied small interior margins to the cells, to keep the text away from the borders and all tables should now be horizontally centred on the page.

[CodingGuruInTraining]

That just about did it! Would you be willing to explain what this code is doing so I know where I went wrong? Also, I'm experiencing some minor issues when I run this code:
- The tables as a whole are left aligned, then some are halfway off the left side. How could you make them centered in the page?
- When I try to add code to repeat the first row, I get an error again about merged cells. Is it a matter of where it is placed in the code or how? I've been trying this code:

Tbl.Rows(1).HeadingFormat = True

- The table gets messed up when it comes across unmerged cells in column 1 (for obvious reasons), which can happen often with these documents. Could there be a check added to see if the cells are merged first and to merge them if they are not? I am thinking something like this (I know this isn't correct, but I'm still learning):

If Case 1: .Cells.Merge = False Then
            .Cells.Merge
            Else Next

- I'd like the horizontally merged cells to be a set height, but still be able to expand if too much content is added (AutoFit I think). My first attempt was with the following code, but it didn't seem to do anything.

If .Cells().Width = InchesToPoints(6.21) Then
                    .Cells.Height = InchesToPoints(0.8)
                End If

I got some other formatting tweaks figured out, but I haven't been able to figure out the ones above yet. Any suggestions would be appreciated!