Reverse Bold macro

[brent chadwick]

Hey guys, I have a lot text that needs to have bold reversed. I found this macro somewhere, it works but is real slow. Any suggestions to rewrite and make faster, or is this the best it gets? Thanks

Sub ReverseBold()
    Dim c
    For Each c In Selection.Characters
        c.Font.Bold = Not c.Font.Bold
    Next c
End Sub

[macropod]

Try:

Sub ReverseBold()
Application.ScreenUpdating = False
Dim Rng As Range, bBld As Boolean
Set Rng = Selection.Characters.First
With Rng
  bBld = .Font.Bold
  Do While .End < Selection.End
    Do While .Characters.Last.Next.Font.Bold = bBld
      If .End < Selection.End Then
        .End = .End + 1
      Else
        Exit Do
      End If
    Loop
    .Font.Bold = Not bBld
    bBld = Not bBld
    .Collapse wdCollapseEnd
  Loop
End With
Application.ScreenUpdating = True
End Sub

[brent chadwick]

Thanks Paul. Again, your code works but it seems to take a long time. For a four line sentence it takes 20+ seconds to change the bold. Doesn't that seem like a long time??

[gmaxey]

Kluncky but fast:

Sub ReverseBoldII()
Application.ScreenUpdating = False
Dim oRng As Range
  Set oRng = Selection.Range
  With oRng.Find
    .Text = "(*)"
    .Font.Bold = False
    .MatchWildcards = True
    With .Replacement
      .Text = "^&"
      .Font.Bold = True
      .Font.DoubleStrikeThrough = True 'any unused font attribute
    End With
    .Execute Replace:=wdReplaceAll
   End With
   Set oRng = Selection.Range
   With oRng.Find
    .Text = "(*)"
    .Font.Bold = True
    .Font.DoubleStrikeThrough = False
    .MatchWildcards = True
    With .Replacement
      .Text = "^&"
      .Font.Bold = False
    End With
    .Execute Replace:=wdReplaceAll
   End With
   Set oRng = Selection.Range
   With oRng.Find
    .Text = "(*)"
    .Font.Bold = True
    .Font.DoubleStrikeThrough = True
    .MatchWildcards = True
    With .Replacement
      .Text = "^&"
      .Font.DoubleStrikeThrough = False
    End With
    .Execute Replace:=wdReplaceAll
   End With
Application.ScreenUpdating = True
End Sub

[macropod]

Originally Posted by brent chadwick

Again, your code works but it seems to take a long time. For a four line sentence it takes 20+ seconds to change the bold. Doesn't that seem like a long time??

On my system, processing a selection with 4440 words spanning 288 lines over 7 pages, of which 456 separate words were bold, took just 2 seconds, as did reversing the process. That seems fast enough for me.

While Greg's code will probably do what you want, my approach avoids any potential interference with whatever other formatting your content might already have (including double-strikethrough).

[brent chadwick]

Would it make a difference if there are a lot fields in these docs? I timed using it a couple times with either of the macro I found and the one that Paul wrote, and for a four sentence paragraph it actually took 20-25 seconds. Suggestions?

[gmaxey]

You have already had one suggesting which apparently you ignored. Paul's code seems fast to me. The only possible issue with it is that it pukes if your selection happens to include the final paragraph mark.

You can try:

Sub ReverseBoldII()
Dim oRng As Range
Application.ScreenUpdating = False
Set oRng = Selection.Characters.First
  Do
    oRng.Font.Bold = Not oRng.Font.Bold
    Set oRng = oRng.Characters.Last.Next
  Loop Until oRng.Start = Selection.Characters.Last.Start
  Application.ScreenUpdating = True
End Sub

[macropod]

Originally Posted by gmaxey

Paul's code seems fast to me. The only possible issue with it is that it pukes if your selection happens to include the final paragraph mark.

Thanks for the heads-up. That could be remedied by replacing:
Set Rng = Selection.Characters.First
with:

With Selection
  Set Rng = .Characters.First
  If .End = ActiveDocument.Range.End Then
    .Characters.Last.Font.Bold = Not .Characters.Last.Font.Bold
    .End = .End - 1
  End If
End With

[brent chadwick]

Thanks Paul for the change in the code, works well. Greg, yours worked well also but it really messed up my bookmarks. Thanks to all for the help-

[gmaxey]

Odd that the find and replace version affects bookmarks as it does. I don't recall encountering that before. Paul any idea as to why?

The loop version doesn't seem to affect bookmarks, but if you have a solution it is mute.

[macropod]

ISTR encountering difficulties at times when F/R code crosses or terminates at a field brace. The gotcha is that toggling the field code display changes what might be found...

[gmaxey]

Paul,

Not this case. In a very simple:
This is a bold test
with "a bold" bookmarked, the code returns:
This is a bold test
and the bookmark shifts left places to:
"s a bol"

Weird

[brent chadwick]

That's what happened to me. I agree-weird.

[macropod]

Ah, OK, I mis-read as a reference to fields. I can see how what you're describing might happen, though I've not encountered it before. Just another little 'gotcha' to be aware of.

[gmaxey]

Paul,

I don't' see a reason for it happening and it seems a first rate bug to me. The code is "finding" text and replacing that text with itself with a different font attribute. There is nothing it the code that I see that should cause bookmarks to shift to the left.

As I said, the code is clunky to begin with. Now it is even more clunky restoring the bookmarks :

Sub ReverseBoldIII()
Application.ScreenUpdating = False
Dim oRI As Range, oRng As Range
Dim oCol As New Collection
Dim oBM As Bookmark
Dim lngIndex As Long
Dim arrRng() As String
  For Each oBM In Selection.Range.Bookmarks
    oCol.Add oBM.Start & "|" & oBM.End
  Next
  Set oRng = Selection.Range.Duplicate
  Set oRI = Selection.Range.Duplicate
  With oRng.Find
    .Text = "*"
    .Font.Bold = False
    .MatchWildcards = True
    With .Replacement
      .Text = "^&"
      .Font.Bold = True
      .Font.DoubleStrikeThrough = True 'any unused font attribute
    End With
    .Execute Replace:=wdReplaceAll
   End With
   Set oRng = Selection.Range.Duplicate
   With oRng.Find
    .Text = "*"
    .Font.Bold = True
    .Font.DoubleStrikeThrough = False
    .MatchWildcards = True
    With .Replacement
      .Text = "^&"
      .Font.Bold = False
    End With
    .Execute Replace:=wdReplaceAll
   End With
   Set oRng = Selection.Range.Duplicate
   oRng.Select
   With oRng.Find
    .Text = "*"
    .Font.Bold = True
    .Font.DoubleStrikeThrough = True
    .MatchWildcards = True
    With .Replacement
      .Text = "^&"
      .Font.DoubleStrikeThrough = False
    End With
    .Execute Replace:=wdReplaceAll
   End With
   Set oRng = Selection.Range
   For lngIndex = 1 To oCol.Count
     Set oBM = oRI.Bookmarks(lngIndex)
     arrRng = Split(oCol.Item(lngIndex), "|")
     oBM.Start = arrRng(LBound(arrRng))
     oBM.End = arrRng(UBound(arrRng))
    Next
Application.ScreenUpdating = True
End Sub