VBA MS Word - Change Color of text after an Apostrophe (my Loop is stuck!)

Chris Macro

Well-known Member
Joined
Nov 2, 2011
Messages
1,343
Hi, I am trying to mimic how the VBA Editor changes commented text to green (with an apostrophe as the indicator) in a Word Document's text. I am approaching this by using the Find function to find all the apostrophe's in my selection and then select to the end of the line and change that selection to green. Unfortunately my code gets stuck in an infinite loop on the first line of my sample text. I believe this is because I am changing the selection range when I use the extend command. Anyone know how I can fix this code or maybe there is another way to approach my problem? Thanks for your time!

I have the following testing Text:


Code:
'Hello World
'It's my car!
 
Dim myOrgColor As Double          'original color of color index 32
Dim myNewColor As Double      'color that was picked in the dialogue
Dim myRGB_R As Integer           ' RGB values of the color that will be
Dim myRGB_G As Integer            'displayed in the dialogue as
Dim myRGB_B As Integer            'It's my car!

Here is my code so far:
Code:
Sub Sample()

    '~~> Loop through the array to get the search text
    
        With Selection.Find
            .ClearFormatting
            .Text = "'"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Execute


            '~~> Change the attributes
            Do Until .Found = False
                Selection.EndKey Unit:=wdLine, Extend:=wdExtend
                Selection.Font.Color = RGB(0, 128, 0)
                Selection.Find.Execute
            Loop
        End With


End Sub
 

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)

ZVI

MrExcel MVP
Joined
Apr 9, 2008
Messages
3,836
Office Version
  1. 2016
  2. 2010
  3. 2007
Platform
  1. Windows
Hi Chris,

Try this code:
Rich (BB code):
Sub ColorComments()
  With ActiveDocument.Content.Find
    .ClearFormatting
    .Text = "'*[^13]"
    .Replacement.ClearFormatting
    .Replacement.Text = ""
    .Replacement.Font.Color = wdColorGreen
    .Format = True
    .Forward = True
    .Wrap = wdFindContinue
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
End Sub

Regards
 
Last edited:

Macropod

Retired Moderator
Joined
Aug 27, 2007
Messages
3,567
Try something based on:
Code:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
Set Rng = Selection.Range
With ActiveDocument.Range
  With .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
  Do While .Find.Found
    .Select
    With Selection
      .EndKey Unit:=wdLine, Extend:=wdExtend
      MsgBox .Text
      .Font.Color = RGB(0, 128, 0)
    End With
    .End = Selection.End
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Rng.Select
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub
The key to getting this to work is to collapse the range to its end and NOT using '.Wrap = wdFindContinue'.

However, since it seems your text lines are terminated by paragraph breaks or line breaks, you could do the lot without code, using a wildcard Find/Replace, where:
Find = '[!^13^l]@[^13^l]
Replace = ^&
and the replacement text colour is specified for the required green hue. As a macro, this becomes:
Code:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range.Find
  .ClearFormatting
  .Text = "'[!^13^l]@[^13^l]"
  With .Replacement
    .Text = "^&"
    .ClearFormatting
    .Font.Color = RGB(0, 128, 0)
  End With
  .Format = True
  .Forward = True
  .Wrap = wdFindContinue
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
End Sub
and will execute much faster than anything using loops and selections.
 

Chris Macro

Well-known Member
Joined
Nov 2, 2011
Messages
1,343
Thank you both as both your solutions are working great! Is there any way your solutions (Paul I was looking at your second procedure that you submitted) could be based off of just a user's selected text? I tried using "Selection.Find" but both subroutines highlighted the entire document still.
 

ZVI

MrExcel MVP
Joined
Apr 9, 2008
Messages
3,836
Office Version
  1. 2016
  2. 2010
  3. 2007
Platform
  1. Windows

ADVERTISEMENT

To work with selection only use With Selection.Find and .Wrap = wdFindStop
 

ZVI

MrExcel MVP
Joined
Apr 9, 2008
Messages
3,836
Office Version
  1. 2016
  2. 2010
  3. 2007
Platform
  1. Windows

ADVERTISEMENT

Chris, I am glad our suggestions were useful :)
 

Chris Macro

Well-known Member
Joined
Nov 2, 2011
Messages
1,343
Thanks you guys again for your help. I did run into an issue that I'm not sure how to address. Is there a way to prevent the find function from highlighting the text green if the occurrence of " ' " is written? I ran the macro on the text of the macro itself and it highlighted the phrase: " '*[^13] ". Since this piece of the code is a text string and not considered a comment I would not like this to be highlighted in green. I believe this should be the only instance of when an apostrophe would not trigger the rest of the text to be highlighted.

I'm guessing one possible solution would be to test if a quote occurred before and after the apostrophe in the same line, but I am not sure if that is the direction I should be looking in to or if there is functionality within the Find function that could handle this. Thank you for your expertise!

Code and Text I used in my testing:

Code:
Sub Color_VBA_Comments()

'Purpose: Looks for a Quote and changes the rest of that line's font color to Green

  With Selection.Find
    .ClearFormatting
    .Text = "'*[^13]"
    .Replacement.ClearFormatting
    .Replacement.Text = ""
    .Replacement.Font.Color = wdColorGreen
    .Format = True
    .Forward = True
    .Wrap = wdFindStop
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
End Sub
 

Chris Macro

Well-known Member
Joined
Nov 2, 2011
Messages
1,343
Thanks Paul, that fixed the problem. Would you mind explaining what that criteria looks for? Or maybe if you know a good resource that could teach me how to understand "'[!^13""""]@[^13]"? It looks like you can do some pretty neat stuff if you know how to write it!
 

Forum statistics

Threads
1,137,060
Messages
5,679,376
Members
419,824
Latest member
Mercy kiara

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top