The code I posted previously take a different approach to the rest of your macro. Try:
Code:
Sub DPU_Definitions()
Application.ScreenUpdating = False
With ActiveDocument
With .Range
'Convert list numbers to text'
.ListFormat.ConvertNumbersToText
'Create placeholder.
.InsertBefore vbCr
.Paragraphs(1).Range.Font.Bold = False
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = True
.Forward = True
.MatchWildcards = False
.Wrap = wdFindContinue
'Delete white spaces before paragraph breaks
.Text = "^w^p"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
'Delete white spaces after paragraph breaks
.Text = "^p^w"
.Execute Replace:=wdReplaceAll
'Clean up definitions
.MatchWildcards = True
.Text = "[:;, ^t]{1,5}means[:;, ]{1,5}"
.Replacement.Text = "^t"
.Replacement.Font.Bold = False
.Execute Replace:=wdReplaceAll
'Remove bold formatting from punctuation and para marks
.Text = "[^13.;,:]"
.Replacement.Text = "^&"
.Font.Bold = True
.Execute Replace:=wdReplaceAll
'Clear space before tabs
.Text = "[ ^160]{1,}^t"
.Replacement.Text = "^t"
.Execute Replace:=wdReplaceAll
'Insert Bold quotes for bold definition text at beginning of sentence
.Text = ""
.Replacement.Text = "^034^&^034"
.Wrap = wdFindStop
End With
Do While .Find.Execute = True
With .Duplicate
Do While .Characters.Last = " "
.Characters.Last.Delete
Loop
.InsertBefore Chr(147)
.InsertAfter Chr(148)
If .Characters.First.Previous = vbCr Then
.InsertAfter vbTab
.Characters.Last.Font.Bold = False
End If
End With
.End = .End + 1
.Collapse wdCollapseEnd
Loop
With .Find
.Wrap = wdFindContinue
'insert tab at beginning of paragraph with a bracket e.g. (a), a), (i), i), (1), 1)
.Text = "^13([\(a-z0-9]@\))"
.Replacement.Text = "^p^t\1"
.Execute Replace:=wdReplaceAll
'Clear colons or commas after tabs.
.Text = "[^t]([:\,]){1,}"
.Replacement.Text = "^t"
.Execute Replace:=wdReplaceAll
'Clear space after tabs
.Text = "^t[ ^160]{1,}"
.Execute Replace:=wdReplaceAll
'Highligt tabs so user can check for errors when code has run
.Wrap = wdFindStop
.Text = "^t"
End With
Do While .Find.Execute = True
With .Duplicate
.HighlightColorIndex = wdYellow
.Start = .Paragraphs(1).Range.Start
If Len(.Text) - Len(Replace(.Text, vbTab, "")) > 1 Then .Characters.Last.Text = " "
End With
.Collapse wdCollapseEnd
Loop
End With
With .Range
'Remove punctuation and insert semi-colon at end of sentence
.Find.Text = "[! ^13]@[!.\!\?:;]^13"
Do While .Find.Execute = True
With .Duplicate
Select Case Trim(.Words.First)
Case "and", "but", "or", "then"
'do nothing
Case Else
.Words.First.InsertAfter ";"
End Select
End With
.Collapse wdCollapseEnd
Loop
End With
'Remove placeholder.
.Paragraphs(1).Range.Delete
With .Range
'Prefix designated bold first words with a tab
.Find.Text = "^13[A-Za-z]"
Do While .Find.Execute = True
With .Duplicate.Paragraphs.Last.Range
If .Style = "Normal" Then
If .Characters.First.Font.Bold = False Then .InsertBefore vbTab
End If
End With
.Collapse wdCollapseEnd
Loop
End With
End With
End Sub