Hi guys, I'm looking to update the macro below. In the word document attached, highlighted row, at the beginning of the definition the quote mark should insert after the square bracket. I also need to remove any punctuation at the end of the definition before the square bracket (the macro below does remove punctuation and replaces it with a semi-colon but I'm not sure how to tell it to remove punctuation if the sentence ends with a square bracket). Any help would be appreciated. Many thanks.
Definitions.docx
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
'Remove colons'
.Text = ":"
.Font.Bold = True
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
With orng.Find
'Remove colons'
.Text = ":"""
.Replacement.Text = """"
.Execute Replace:=wdReplaceAll
End With
With orng.Find
'remove bold from spaces after the word means
.Text = "means "
.Replacement.Text = "means "
.Replacement.Font.Bold = False
.Execute Replace:=wdReplaceAll
End With
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
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"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
With orng.Find
'Remove double quotes'
.Text = """"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
Set orng = ActiveDocument.Range
'Replace tab with space'
With orng.Find
.Text = "^t"
.Replacement.Text = " "
.Execute Replace:=wdReplaceAll
End With
Set orng = ActiveDocument.Range
'Bold quotes
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.Font.Bold = False
orng.Characters.Last = vbTab
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
'Remove the words means from each definition and insert a tab'
Set orng = ActiveDocument.Range
With orng.Find
.Text = "^tmeans"
.Replacement.Text = "^t"
.Execute Replace:=wdReplaceAll
End With
'Remove the words means and space before and insert a tab'
Set orng = ActiveDocument.Range
With orng.Find
.Text = " ^tmeans"
.Replacement.Text = "^t"
.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
With orng.Find
'Remove colons'
.Text = ":"""
.Replacement.Text = """"
.Execute Replace:=wdReplaceAll
End With
'Highligt tabs
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
'Insert semi-colon at end of sentences but not for and, but, or
Set orng = ActiveDocument.Range
With orng.Find
.Text = ".^p"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
End With
For Each Para In ActiveDocument.Paragraphs
With Para.Range
If Len(.Text) > 2 Then
If Not .Characters.Last.Previous Like "[.!?:;]" Then
Select Case .Words.Last.Previous.Words(1)
Case "and", "but", "or"
'do nothing
Case Else
.Characters.Last.InsertBefore ";"
End Select
End If
End If
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 Sub
Code:
Sub ResetFRParameters()
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
lbl_Exit:
Exit Sub
End Sub