VBA Applying Definition Styles Error

[Shelley Lou]

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

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

[Guessed]

The easiest fix would be to leave the 'means' text in until the styles have been applied and then remove the leading word.

[Shelley Lou]

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.

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

[Shelley Lou]

I thought I had fixed the issue with this code but having run it on a document today, the issue isn't fixed. Quick recap, if there is an opening bracket in column 2 the code is removing the bracket and first word and applying a sub level style to it which it shouldn't do (see earlier posts).

I originally moved the Call DPU_ApplyDefinitionStylesToTable before the code that removes the word 'means' and thought that had done the trick - below if the full code complete with the call in codes.

Not sure where I am going wrong.

Sub DPU_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 DPU_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
For Each oTbl In ActiveDocument.Tables
    Set rRng = oTbl.Range
    rRng.End = rRng.End - 2
    If rRng.Characters.Last = ";" Then rRng.Characters.Last = "."
  Next oTbl
End If
   Next i
   End With
   Call DPU_TableLeadingSpaces
Application.ScreenUpdating = True
Set rRng = Nothing
Set oTbl = Nothing
Set rCell = Nothing
Set oBorder = Nothing
End Sub

Sub DPU_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

Sub DPU_TableLeadingSpaces()
'Remove any leading spaces in table row cells
Application.ScreenUpdating = False
Dim Tbl As Table, Cll As Cell
For Each Tbl In ActiveDocument.Tables
  For Each Cll In Tbl.Range.Cells
    With Cll.Range
      If Len(.text) > 2 Then
        Do While .Characters.First.text = " "
          .Characters.First.text = vbNullString
        Loop
      End If
      If Len(.text) > 2 Then
        Do While .Characters.Last.Previous.text = " "
          .Characters.Last.Previous.text = vbNullString
        Loop
      End If
    End With
  Next
Next
Application.ScreenUpdating = True
End Sub