#1
|
|||
|
|||
Create heading row for table
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 |
#2
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
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 |
#4
|
||||
|
||||
Quote:
Quote:
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
||||
|
||||
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
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#6
|
|||
|
|||
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.
|
#7
|
|||
|
|||
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.
|
Thread Tools | |
Display Modes | |
|
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 |