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