Removing trailing bold space from bold phrases

[coops666]

Hi

I have created the following very basic macro to add non bold quotes around bold phraseswithin a selection.
My problem is, that if there is a bold space after the phrase. Is there a way to remove the bold space, but not between bold words. I hope that makes sense.


Sub AddQuotestoSelection()
'to stop people not selecting
If Selection.Range.Start = Selection.Range.End Then
MsgBox "Remember to select the paragraphs first!"
Exit Sub
End If
'adds speechmarks around any bold text
Selection.Find.ClearFormatting
Selection.Find.font.Bold = True
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ChrW(8220) & "^&" & ChrW(8221)
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False

End With
Selection.Find.Execute Replace:=wdReplaceAll

'replaces bold speechmarks with non bold speechmarks
Selection.Find.ClearFormatting
Selection.Find.font.Bold = True
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.font.Bold = False
With Selection.Find
.Text = """"
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindStop
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False

End With
Selection.Find.Execute Replace:=wdReplaceAll



End Sub

[macropod]

Try something along the lines of:

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[^034^0147^0148][^32^0160^09-^13]"
.Replacement.Text = ""
.Format = True
.Forward = True
.Font.Bold = True
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
i = i + 1
.Characters.Last.Font.Bold = False
If .End = ActiveDocument.Range.End Then Exit Do
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
MsgBox i & " instances processed."
End Sub
The above code will also un-bold trailing tabs, line, paragraph & Section breaks

[coops666]

Hi Paul

Thank you for your reply but uUnfortunately this did not work. No bold characters were found.

[macropod]

In that case, it's because you have no bold spaces after the quoted text. If you want to combine quoting a bold string and unbolding a trailing space, try something along the lines of:

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Format = True
.Forward = True
.Font.Bold = True
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
i = i + 1
If .Characters.Last.Text Like "[ " & Chr(9) & "-" & Chr(13) & "]" Then
.Characters.Last.Font.Bold = False
.End = .End - 1
End If
If Not .Characters.Last.Text Like "[ " & Chr(34) & Chr(148) & "]" Then .InsertAfter Chr(148)
If Not .Characters.First.Text Like "[ " & Chr(34) & Chr(147) & "]" Then .InsertBefore Chr(147)
.Characters.First.Font.Bold = True
If .End = ActiveDocument.Range.End Then Exit Do
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
MsgBox i & " instances processed."
End Sub
Note: The above code can be re-run on a document with quoted bold text without re-quoting what's already there.

[coops666]

Hi Paul

That is great, thank you.

Any chance it could work on selected text only?

[macropod]

Try:

Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, i As Long
With Selection
Set Rng = .Range
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Format = True
.Forward = True
.Font.Bold = True
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
If .InRange(Rng) Then
i = i + 1
If .Characters.Last.Text Like "[ " & Chr(9) & "-" & Chr(13) & "]" Then
.Characters.Last.Font.Bold = False
.End = .End - 1
End If
If Not .Characters.Last.Text Like "[ " & Chr(34) & Chr(148) & "]" Then .InsertAfter Chr(148)
If Not .Characters.First.Text Like "[ " & Chr(34) & Chr(147) & "]" Then .InsertBefore Chr(147)
.Characters.First.Font.Bold = True
Else
Exit Do
End If
If .End = ActiveDocument.Range.End Then Exit Do
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End With
Application.ScreenUpdating = True
MsgBox i & " instances found."
End Sub

[coops666]

Paul that is wonderful. Thank you ever so much. It has also given me a bit more understanding of VBA