#1
|
|||
|
|||
VBA Applying Definition Styles Error
I have been working with this code for a couple of years, but have only recently discovered an error when assigning numbering styles to sublevel paragraphs that start with (a), (i), (A) or (1).
The error occurs if the paragraph starts with an opening bracket but is not related to a sublevel. It deletes the bracket and the first word after the bracket and then assigns a sublevel numbering style to the paragraph. I'm not sure what to add to the ApplyDefinitionStylesToTable code to fix this issue, so would appreciate any advice. This image is before code has run Image1.JPG This image is after the code has run, Base Figure should not be a sublevel - the opening bracket and the word 'either' has been deleted Image2.JPG This image is what the table text should look like Image3.JPG Document of Table.docx Code:
Sub TextToTables() Dim rRng As Range, rCell As Range 'Convert text to table Dim oBorder As Border Dim oTbl As Table Dim i As Integer Application.ScreenUpdating = False Set rRng = ActiveDocument.Range Set oTbl = rRng.ConvertToTable(Separator:=wdSeparateByTabs, NumColumns:=2, AutoFitBehavior:=wdAutoFitFixed) With oTbl .Style = "Table Grid" .ApplyStyleHeadingRows = True .ApplyStyleLastRow = False .ApplyStyleFirstColumn = True .ApplyStyleLastColumn = False .Columns.PreferredWidth = InchesToPoints(2.7) .Columns(2).PreferredWidth = InchesToPoints(3.63) For Each oBorder In .Borders oBorder.LineStyle = wdLineStyleNone Next oBorder For i = 1 To .Rows.count 'check each row Set rCell = .Cell(i, 1).Range 'set a range to the cells in column 1 rCell.Style = "DefBold" 'apply the style to the range Set rCell = .Cell(i, 2).Range 'set a range to the cells in column 2 rCell.Collapse 1 'collapse the range to its start rCell.MoveEndWhile "means,:" 'move the end of the range to include any of these characters If rCell.text Like "means*" Then 'if that range starts with 'means' rCell.MoveEndWhile Chr(32) 'move the end of the range to include any following spaces rCell.text = "" 'and empty the range End If Next i End With Application.ScreenUpdating = True Set rRng = Nothing Set oTbl = Nothing Set rCell = Nothing Set oBorder = Nothing Call ApplyDefinitionStylesToTable End Sub Sub ApplyDefinitionStylesToTable() 'Apply housestyle definition numbering to column 2 of table Application.ScreenUpdating = False Dim r As Long, i As Long With ActiveDocument.Tables(1) For r = 1 To .Rows.count With .Cell(r, 2).Range If .Characters.First <> "(" Then .Style = "Definition Level A" Else i = Asc(Split(Split(.text, "(")(1), ")")(0)) Select Case i Case 97 To 104, 106 To 117, 119, 121 To 122: .Style = "Definition Level 1" 'LowercaseLetter Case 105, 118, 120: .Style = "Definition Level 2" 'LowercaseRoman Case 65 To 90: .Style = "Definition Level 3" 'UppercaseLetter Case 48 To 57: .Style = "Definition Level 4" 'Arabic End Select .Collapse wdCollapseStart .MoveEndUntil " " .End = .End + 1 .Delete End If End With Next End With Application.ScreenUpdating = True End Sub |
#2
|
||||
|
||||
The easiest fix would be to leave the 'means' text in until the styles have been applied and then remove the leading word.
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#3
|
|||
|
|||
VBA Applying Definition Styles Error
Hi Andrew, thank you so much for the suggestion, I couldn't see it myself - I've moved the Call ApplyDefinitionStylesToTable before the code that deletes the word 'means' and that seems to have done the trick.
Code:
Sub TextToTables() Dim rRng As Range, rCell As Range 'Convert text to table Dim oBorder As Border Dim oTbl As Table Dim i As Integer Application.ScreenUpdating = False Set rRng = ActiveDocument.Range Set oTbl = rRng.ConvertToTable(Separator:=wdSeparateByTabs, NumColumns:=2, AutoFitBehavior:=wdAutoFitFixed) With oTbl .Style = "Table Grid" .ApplyStyleHeadingRows = True .ApplyStyleLastRow = False .ApplyStyleFirstColumn = True .ApplyStyleLastColumn = False .Columns.PreferredWidth = InchesToPoints(2.7) .Columns(2).PreferredWidth = InchesToPoints(3.63) For Each oBorder In .Borders oBorder.LineStyle = wdLineStyleNone Next oBorder Call ApplyDefinitionStylesToTable For i = 1 To .Rows.count 'check each row Set rCell = .Cell(i, 1).Range 'set a range to the cells in column 1 rCell.Style = "DefBold" 'apply the style to the range Set rCell = .Cell(i, 2).Range 'set a range to the cells in column 2 rCell.Collapse 1 'collapse the range to its start rCell.MoveEndWhile "means,:" 'move the end of the range to include any of these characters If rCell.text Like "means*" Then 'if that range starts with 'means' rCell.MoveEndWhile Chr(32) 'move the end of the range to include any following spaces rCell.text = "" 'and empty the range End If Next i End With Application.ScreenUpdating = True Set rRng = Nothing Set oTbl = Nothing Set rCell = Nothing Set oBorder = Nothing End Sub |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Applying a new Style Set isn't changing the appearance of my styles | mrspawkypig | Word | 2 | 01-30-2023 07:53 PM |
Styles and not applying correctly | GinnyBcore | Word | 1 | 10-02-2018 03:18 PM |
Applying styles dynamically? | arkofcovenant | Mail Merge | 1 | 05-08-2015 06:02 AM |
Does Word do this when applying Styles to a paragraph a second time? | Bobosmite | Word | 2 | 04-17-2012 02:13 PM |
Dumping styles definition | gouletp | Word | 3 | 09-06-2011 10:29 AM |