Hi, I need to update the macro below as it currently isn't working correctly. I work with pdf converted to Word documents so formatting can be all over the place and not consistent. Currently the macro only works if there is already a tab after the bold definition text at the beginning of each sentence. If there is a space or colon tab or space colon space, the macro put all this text into column 1 which is incorrect. I'm looking for the macro to replace the space with a tab and also remove the colons from the bold definition text. Can anyone help me update this please. Many thanks.
Space to Tab 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
.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