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

Page 1 of 2

Show 40 post(s) from this thread on one page

Microsoft Office Forums (https://www.msofficeforums.com/)

- Word VBA (https://www.msofficeforums.com/word-vba/)

- - Combining 2 tables into 1 and use Table2's column widths (hoping for workaround dealing merged cells (https://www.msofficeforums.com/word-vba/27938-combining-2-tables-into-1-use-table2s.html)

CodingGuruInTraining

09-19-2015 06:43 PM

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

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

09-20-2015 12:01 AM

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

09-21-2015 08:10 PM

1 Attachment(s)

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

09-21-2015 09:29 PM

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

09-22-2015 05:16 AM

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

09-22-2015 05:48 AM

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

09-22-2015 07:14 PM

Yes, that is correct.

macropod

09-22-2015 10:01 PM

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

Code:

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

09-23-2015 08:37 PM

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

09-23-2015 09:08 PM

Quote:

Originally Posted by CodingGuruInTraining (Post 88707)

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.

Quote:

Originally Posted by CodingGuruInTraining (Post 88707)

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

09-24-2015 09:09 PM

Quote:

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:

Code:

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

09-24-2015 09:42 PM

Quote:

Originally Posted by CodingGuruInTraining (Post 88764)

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...

Quote:

Originally Posted by CodingGuruInTraining (Post 88764)

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

09-25-2015 05:58 PM

1 Attachment(s)

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

09-25-2015 07:10 PM

Try:

Code:

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

09-25-2015 11:48 PM

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:

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):

Code:

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.

Code:

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!

All times are GMT -7. The time now is 07:16 PM.

Page 1 of 2

Show 40 post(s) from this thread on one page

Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2025, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2025 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft