Create heading row for table

jeffreybrown · #1 12-07-2019, 01:52 PM

I have many table with a title directly above the table. This code below works just fine to add that header as part of the table in the newly created row 1; however, I just ran into a table that has vertically merged cells and therefore throwing an error when running the code.

I know merge cells are not ideal, but in this situation they will have to remain.

Is there a way to access the table even with the merged cells and still add the text above the table as the title in row 1?

In the attachment there is a before and after?

Code:

Sub CleanupTables()
    Dim aTbl    As Table
    Dim aRng    As Range
    Dim aRow    As Row
    
    Application.ScreenUpdating = False
    
    For Each aTbl In ActiveDocument.Tables
        Set aRng = aTbl.Range
        aRng.MoveStart Unit:=wdParagraph, Count:=-1
        aRng.Select
        ActiveWindow.ScrollIntoView aRng, True
        With aTbl                        
            If MsgBox("Does this table have a table name", vbYesNo) = vbYes Then
                Set aRow = aTbl.Rows.Add(BeforeRow:=aTbl.Rows(1))
                aRow.Range.Cells.Merge
                Set aRng = aRng.Paragraphs(1).Range
                aRng.MoveEnd Unit:=wdCharacter, Count:=-1
                aRow.Range.Cells(1).Range.FormattedText = aRng.FormattedText
                aRng.Paragraphs(1).Range.Delete
                aRow.Borders(wdBorderTop).LineStyle = wdLineStyleNone
                aRow.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
                aRow.Borders(wdBorderRight).LineStyle = wdLineStyleNone
                aRow.Range.Style = "Caption"
                aRow.Range.ParagraphFormat.Reset
            End If
        End With
    Next aTbl
            
    Application.ScreenUpdating = True
    
End Sub

macropod · #2 12-08-2019, 12:14 AM

You should be able to use something like:

Code:

Sub CleanupTables()
Application.ScreenUpdating = False
Dim Tbl As Table, Rng As Range, PrefWdthType As Long, PrefWwdthVal As Single, bFit As Boolean
For Each Tbl In ActiveDocument.Tables
  With Tbl
    Set Rng = .Range.Characters.First.Previous.Paragraphs.First.Range
    If Rng.Text Like "Table [0-9]*" Then
      Rng.ParagraphFormat.TabStops.ClearAll
      bFit = .AllowAutoFit
      .AllowAutoFit = False
      PrefWdthType = .PreferredWidthType
      PrefWwdthVal = .PreferredWidth
      With Rng
        .End = .End - 1
        .ConvertToTable Separator:=vbTab, NumRows:=1, NumColumns:=1, Format:=wdTableFormatNone, ApplyHeadingRows:=True
        With .Tables(1)
          If PrefWwdthVal <> 9999999 Then
            .PreferredWidthType = PrefWdthType
            .PreferredWidth = PrefWwdthVal
          End If
          With .Range.Cells(1).Range
            .Style = "Caption"
            .ParagraphFormat.Reset
          End With
        End With
      End With
      .Range.Characters.First.Previous.Delete
      .AllowAutoFit = bFit
    End If
  End With
Next
Application.ScreenUpdating = True
End Sub

In a general sense, the above works, but something in your document is preventing the code from picking up the table width, so the new row's width is independent of the rest of the table's width.

jeffreybrown · #3 12-08-2019, 06:39 AM

Hi Paul,

This worked except for the first new row did not size with the table.

I found a thread where you suggested to remove the table and place in Excel, unmerge the cells there and then put back into Word.

This might work well for my needs as I don't think table with vertically merged cells will be a large number.

So, my thought, do as I mentioned above, but run my original code but add a skip when vertically merged cells are identified. As those tables are identified, I can write down the table number and deal with them one by one.

I found this, but is this the best to skip? I only need to display and then skip if vertical merged cells are identified, but I don't need the message that gives the error description.

Code:

Sub tableformat()
    Dim i As Long
    Dim oRow As Row
    Dim oCol As Column
    On Error GoTo ErrHandler
    For i = 1 To Selection.Tables.Count
        For Each oRow In Selection.Tables(i).Rows
        Next oRow
NextStep:
        For Each oCol In Selection.Tables(i).Columns
        Next oCol
NextTable:
    Next i
    Exit Sub
ErrHandler:
    Select Case Err
        Case 5991
            MsgBox "Table #" & i & " has vertically merged cells"
            Resume NextStep
        Case Else
            MsgBox "Error " & Err.Number & ": " & _
                Err.Description & " in table #" & i
            Resume NextTable
    End Select
End Sub

Note: On further looking, I see the two errors are for checking for merged rows and then checking merged columns. In my case, the original error in post #1 was due to the vertically merged and not the horizontal. So far in all the tables I've been cleaning up have multiple column merged and never an error adding the top row.

macropod · #4 12-08-2019, 04:29 PM

Quote:

Originally Posted by jeffreybrown

This worked except for the first new row did not size with the table.

As I mentioned in my previous reply:

Quote:

Originally Posted by macropod

something in your document is preventing the code from picking up the table width, so the new row's width is independent of the rest of the table's width.

When I look at your table's size in Word, the width is set to 69.9%. For reasons I don't understand, though, in VBA the width is returned as undefined. The following code overcomes that by getting the width of each cell on the first row.

Code:

Sub CleanupTables()
Application.ScreenUpdating = False
Dim Tbl As Table, Rng As Range, c As Long, s As Single, PrefWdthType As Long
For Each Tbl In ActiveDocument.Tables
  With Tbl
    PrefWdthType = .PreferredWidthType: s = 0
    Set Rng = .Range.Characters.First.Previous.Paragraphs.First.Range
    With Rng
      With Tbl.Range
        For c = 1 To .Cells.Count
          If .Cells(c).RowIndex = 1 Then
            s = s + .Cells(c).Width
          Else
            Exit For
          End If
        Next
      End With
      If .Text Like "Table [0-9]*" Then
        .Style = "Caption"
        .ParagraphFormat.Reset
        .End = .End - 1
        .ConvertToTable Separator:=vbTab, NumRows:=1, NumColumns:=1, Format:=wdTableFormatNone, ApplyHeadingRows:=True
        With .Tables(1)
          .PreferredWidthType = wdPreferredWidthPoints
          .PreferredWidth = s
          .Cell(1, 1).PreferredWidth = 0
          .Rows.LeftIndent = Tbl.Rows.LeftIndent
          .RightPadding = Tbl.LeftPadding
          .LeftPadding = Tbl.RightPadding
        End With
        .Characters.Last.Next.Text = vbNullString
        With .Tables(1)
          .PreferredWidthType = wdPreferredWidthPoints
          .PreferredWidth = s
          .Range.Cells.PreferredWidthType = PrefWdthType
          .PreferredWidthType = PrefWdthType
        End With
      End If
    End With
  End With
Next
Application.ScreenUpdating = True
End Sub

Guessed · #5 12-08-2019, 06:14 PM

I would do it this way

Code:

Sub CleanupTables2()
  Dim aTbl    As Table
  Dim aRng    As Range
  Dim aRow    As Row
  Dim aRng2    As Range
  Dim dblEnd As Double
  Dim aCell As Cell
  Dim iCounter As Integer
  
  On Error GoTo errHandle
  
  For iCounter = 1 To ActiveDocument.Tables.Count
    Set aTbl = ActiveDocument.Tables(iCounter)
    Set aRng = aTbl.Range
    aRng.MoveStart Unit:=wdParagraph, Count:=-1
    aRng.Select
    ActiveWindow.ScrollIntoView aRng, True
    With aTbl
      If MsgBox("Does this table have a table name", vbYesNo) = vbYes Then
        dblEnd = aTbl.Range.End
        aTbl.Rows.Add
        Set aRng2 = ActiveDocument.Range(dblEnd, aTbl.Range.End)
        aRng2.Cells.Merge
        Set aRng2 = ActiveDocument.Range(aTbl.Range.Start, dblEnd)
        aRng2.Relocate Direction:=wdRelocateDown
        Set aRng = aRng.Paragraphs(1).Range
        aRng.MoveEnd Unit:=wdCharacter, Count:=-1
        Set aCell = aTbl.Cell(1, 1)
        aCell.Range.FormattedText = aRng.FormattedText
        aRng.Paragraphs(1).Range.Delete
        aCell.Borders(wdBorderTop).LineStyle = wdLineStyleNone
        aCell.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
        aCell.Borders(wdBorderRight).LineStyle = wdLineStyleNone
        aCell.Range.Style = "Caption"
        aCell.Range.ParagraphFormat.Reset
      End If
    End With
NextTable:
  Next iCounter
  
  Exit Sub

errHandle:
  MsgBox "Error " & Err.Number & ": " & Err.Description & " in selected table"
  aTbl.Range.HighlightColorIndex = wdPink
  Resume NextTable
End Sub

jeffreybrown · #6 12-08-2019, 06:51 PM

Thank you both for your replies. I'm on the road right now with no computer access. I'll be able to test next weekend.

jeffreybrown · #7 12-15-2019, 04:49 PM

Thanks again to both of you. I just got back and these two options work well. Once I get back to work I can see which one will fit in best.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Want to copy & paste a table underneath itself x no. of time, table found through style heading name	fly545	Word VBA	11	01-16-2020 05:53 PM
Can I create a page number from a non-Heading style?	techwriter3k	Word	9	09-25-2019 06:58 AM
Deleting Blank Space between table heading and table rows	Pete Jones	Word Tables	5	01-22-2018 04:11 PM
Heading row disappears from table styles when pasted table is selected	andrewballem	Word Tables	2	11-12-2013 05:18 AM
Create and save custom heading style	ubns	Word	3	08-01-2012 09:42 PM