Thread: [Solved] Create heading row for table
View Single Post
 
Old 12-08-2019, 12:14 AM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 22,467
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

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.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote