Hi Andrew, I've been running the code on some test documents and I've come across a couple of issues that the macro isn't picking up.
1. After the Bold Definition text, if there is a bold space and not a tab the macro puts the whole definition into column 1.
2. If the Bold Definition text is on a line on its own and sub-levels (a), (b) etc. are on the next line the macro doesn't pick this up and puts (a) into column 1.
3. If the word 'means' appears additionally in the sentence the macro is deleting the word and inserting a tab, e.g. in relation to any group company means any other company
Is there something we could add to the code to stop this happening?
Thanks, Shelley
Before Macro TEST DOC.docx
After Macro TEST DOC.docx
Code:
Sub DPU_DefinitionTabulator()
Dim aRng As Range, aTbl As Table, aPara As Paragraph, aCell As Cell, oBorder As Border
Set aRng = ActiveDocument.Range
For Each aPara In aRng.Paragraphs
aPara.Range.Words.Last.Font.Reset 'remove bold from paragraph marks and autonumbers
Next aPara
With aRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[:;, ^t]{1,5}means[:;, ]{1,5}" 'replace means with a tab
.Replacement.Text = "^t"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
.Text = "[ ]{2,9}" 'multiple spaces reduced to one
.Replacement.Text = " "
.Execute Replace:=wdReplaceAll
Set aRng = ActiveDocument.Range
aRng.ListFormat.ConvertNumbersToText 'make lists hard coded
.Text = "^w^p" 'paragraphs ending with whitespace have spaces removed
.Replacement.Text = "^p"
.MatchWildcards = False
.Execute Replace:=wdReplaceAll
.Text = ".^p" 'paragraphs ending with ], add semi-colon in front of ]
.Replacement.Text = ";^p"
.Execute Replace:=wdReplaceAll
.Text = ".]^p" 'paragraphs ending with ], add semi-colon in front of ]
.Replacement.Text = ";]^p"
.Execute Replace:=wdReplaceAll
.Text = " ([;:,]{1,5})" 'space before punctuation removed
.Replacement.Text = "\1"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
.Text = "^13([a-z])\)" 'make sure lists with unopened brackets a) get opening bracket (a)
.Replacement.Text = "^13(\1)"
.Execute Replace:=wdReplaceAll
.Text = "^13(?)" 'If paragraph starts non-bold
'.Replacement.Text = "|\1" 'Option: keep all paragraphs in a definition in one row
.Replacement.Text = "^p^t\1" 'Option: if you want separate rows per paragraph
.MatchWildcards = True
.Font.Bold = False
.Execute Replace:=wdReplaceAll
.Text = "([!^13])^t" 'find tabs preceded by non-bold character other than a carriage return
.Replacement.Text = "\1zzTabzz" 'replace with a replaceable unique string
.Font.Bold = False
.Execute Replace:=wdReplaceAll
End With
Set aRng = ActiveDocument.Range
Set aTbl = aRng.ConvertToTable(Separator:=wdSeparateByTabs, NumColumns:=2, AutoFitBehavior:=wdAutoFitFixed)
With aTbl
.Style = "Table Grid Light" 'choose a table style that matches your preferred table look
.ApplyStyleHeadingRows = False
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True 'make sure the table style has a bold first column
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = False
.Range.Style = "Definition Level 1"
For Each aCell In .Columns(1).Cells
aCell.Range.Style = "DefBold"
If aCell.Range.Characters.First = "[" Then
aCell.Range.Characters.First.InsertAfter Text:=""""
aCell.Range.Characters.Last.InsertBefore Text:=""""
ElseIf Len(aCell.Range.Text) > 2 Then
aCell.Range.Characters.First.InsertBefore Text:=""""
aCell.Range.Characters.Last.InsertBefore Text:=""""
End If
Next aCell
.Columns.PreferredWidthType = wdPreferredWidthPoints
.Columns.PreferredWidth = InchesToPoints(2.7)
.Columns(2).PreferredWidth = InchesToPoints(3.63)
For Each oBorder In .Borders
oBorder.LineStyle = wdLineStyleNone
Next oBorder
End With
'Reinstate the tabs and paragraphs
With aRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
.Text = "|"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Text = "zzTabzz"
.Replacement.Text = "^t" 'or a space if you prefer
.Execute Replace:=wdReplaceAll
End With
'Remove all local formatting
ActiveDocument.Range.Font.Reset
Call DPU_ApplyHeadingStylesToTableTable
End Sub
Code:
Sub DPU_ApplyHeadingStylesToTableTable()
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 1"
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 2" 'LowercaseLetter
Case 105, 118, 120: .Style = "Definition Level 3" 'LowercaseRoman
Case 65 To 90: .Style = "Definition Level 4" 'UppercaseLetter
Case 48 To 57: .Style = "Definition Level 5" 'Arabic
End Select
.Collapse wdCollapseStart
.MoveEndUntil " "
.End = .End + 1
.Delete
End If
End With
Next
End With