Hi Macropod, many thanks for the code. I'm having an error with 'Do While.Find.Found = True' - error says 'Method or data member not found'. I have inserted the full code I'm trying to get it to work in after your code.
Definition Test Doc.docx
Code:
'Remove punctuation and insert semi-colon at end of sentence
Set orng = ActiveDocument.Range
With orng.Find
.Wrap = wdFindStop
.MatchWildcards = True
.Text = "[! ^13]@[!.\!\?:;]^13"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
Do While .Find.Found = True
Select Case Trim(.Words.First)
Case "and", "but", "or", "then"
'do nothing
Case Else
.Words.First.InsertAfter ";"
End Select
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Code:
Sub DPU_Definitions()
Dim orng As Range
Dim Para As Paragraph
Application.ScreenUpdating = False
'Create placeholder.
ActiveDocument.Range.InsertBefore vbCr
ActiveDocument.Paragraphs(1).Range.Font.Bold = False
'Convert numbers to text'
ActiveDocument.Range.ListFormat.ConvertNumbersToText
Set orng = ActiveDocument.Range
ResetFRParameters
With orng.Find
'Delete white spaces before paragraph breaks
.Text = "^w^p"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
End With
With orng.Find
'Delete white spaces after paragraph breaks
.Text = "^p^w"
.Execute Replace:=wdReplaceAll
End With
With orng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[:;, ^t]{1,5}means[:;, ]{1,5}"
.Replacement.Text = "^t"
.Replacement.Font.Bold = False
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
With orng.Find
Set orng = ActiveDocument.Range
With orng.Find
'Remove bold formatting from punctuation and para marks
.Text = "[" & Chr(13) & ".;,:]"
.MatchWildcards = True
.Font.Bold = True
.Replacement.Font.Bold = False
.Execute Replace:=wdReplaceAll
End With
'Clear space before tabs
With orng.Find
.Text = " ^t"
.Replacement.Text = "^t"
.Replacement.Font.Bold = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
Set orng = ActiveDocument.Range
'Insert Bold quotes for bold definition text at beginning of sentence
With orng.Find
.Text = ""
.Replacement.Text = "^034^&^034"
.Font.Bold = True
.Format = True
.MatchWildcards = True
While .Execute
If Not InStr(orng.Text, Chr(13)) Then
While orng.Characters.Last = Chr(32)
orng.Characters.Last.Font.Bold = False
orng.End = orng.End - 1
Wend
orng.Text = Chr(34) & orng.Text & Chr(34)
If orng.Characters.First.Previous = Chr(13) Then
orng.Collapse wdCollapseEnd
orng.Characters.Last = vbTab
orng.Font.Bold = False
Else
orng.Collapse wdCollapseEnd
End If
End If
Wend
End With
ResetFRParameters
Set orng = ActiveDocument.Range
'insert tab at beginning of paragraph with a bracket e.g. (a), (i), (1)
With orng.Find
.MatchWildcards = True
.Text = "^13(\([a-z0-9]{1,}\))"
.Replacement.Text = "^p^t\1"
.Execute Replace:=wdReplaceAll
End With
'insert tab at beginning of paragraph e.g a), 1), i), 100 etc.
With orng.Find
.MatchWildcards = True
.Text = "^13([a-z0-9\)]{1,})"
.Replacement.Text = "^p^t\1"
.Execute Replace:=wdReplaceAll
End With
Set orng = ActiveDocument.Range
'Clears colons or commas after tabs.
With orng.Find
.Text = "[^t]([:\,]){1,}"
.Replacement.Text = "^t"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
'Clear space after tabs
With orng.Find
.Text = "^t "
.Replacement.Text = "^t"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
'Highligt tabs so user can check for errors when code has run
Set orng = ActiveDocument.Range
Options.DefaultHighlightColorIndex = wdYellow
With orng.Find
.Text = "^t"
.Replacement.Text = "^t"
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
End With
ResetFRParameters
Set orng = ActiveDocument.Range
With orng.Find
.Text = "^t"
Do While .Execute
orng.Start = orng.Paragraphs(1).Range.Start
If Len(.Text) - Len(Replace(.Text, vbTab, "")) > 1 Then orng.Characters.Last.Text = " "
orng.Collapse wdCollapseEnd
Loop
End With
'Remove punctuation and insert semi-colon at end of sentence
Set orng = ActiveDocument.Range
With orng.Find
.Wrap = wdFindStop
.MatchWildcards = True
.Text = "[! ^13]@[!.\!\?:;]^13"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
Do While .Find.Found = True
Select Case Trim(.Words.First)
Case "and", "but", "or", "then"
'do nothing
Case Else
.Words.First.InsertAfter ";"
End Select
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Next
'Remove placeholder.
ActiveDocument.Paragraphs(1).Range.Delete
Set orng = ActiveDocument.Range
With orng.Find
.Text = "^13[A-Za-z]"
.MatchWildcards = True
Do While .Execute
If orng.Paragraphs(2).Style = "Normal" And _
orng.Paragraphs(2).Range.Characters(1).Font.Bold = False Then
orng.Paragraphs(2).Range.InsertBefore vbTab
End If
orng.Collapse 0
Loop
End With
Application.ScreenUpdating = True
lbl_Exit:
Set orng = Nothing
Exit Sub
End With
End With
End Sub