Find a word and underline with color

gailb
3StarLounger
Posts: 254
Joined: 09 May 2020, 14:00

Find a word and underline with color

Post by gailb »

At the moment, this VBA works find for finding the word "believe", but how can it be converted to find variations as well. Example, "believes", "believed".

It still finds the word believe no matter if it has the "s" or the "ed" on the end, but of course it will not highlight the entire word.

If there is a more succinct macro that is fine with me.

Code: Select all

Sub HighlightStrings()
    
    Application.ScreenUpdating = False
    
    Dim Rng     As range
    Dim cFnd    As String: cFnd = "believe"
    Dim xTmp    As String
    Dim x       As Long
    Dim m       As Long
    Dim y       As Long: y = Len(cFnd)
    
    For Each Rng In range("G2", range("G" & Rows.Count).End(xlUp))
      With Rng
        m = UBound(Split(Rng.Value, cFnd))
        If m > 0 Then
          xTmp = ""
          For x = 0 To m - 1
            xTmp = xTmp & Split(Rng.Value, cFnd)(x)
            With .Characters(Start:=Len(xTmp) + 1, Length:=y)
                .Font.ColorIndex = 3
                .Font.Underline = xlUnderlineStyleSingle
            End With
            xTmp = xTmp & cFnd
          Next
        End If
      End With
    Next Rng
    
    Application.ScreenUpdating = True
    
End Sub

User avatar
ChrisGreaves
PlutoniumLounger
Posts: 15498
Joined: 24 Jan 2010, 23:23
Location: brings.slot.perky

Re: Find a word and underline with color

Post by ChrisGreaves »

gailb wrote:
29 Dec 2021, 20:18
At the moment, this VBA works find for finding the word "believe", but how can it be converted to find variations as well. Example, "believes", "believed".
Hi Gail, try running this code. Is it close to what you want?

Code: Select all

Function FontMe(rng As Range)
    rng.Words(1).Font.Color = wdColorOrange
End Function
Sub Macro1()
    With Selection.Find
        .Text = "believe"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    While Selection.Find.Execute
        Call FontMe(Selection.Range)
    Wend
End Sub
This code can be improved, for example by allowing a character style as a parameter to the function, and an InputBox to let the user key in the generic search string.
Cheers
Chris
You do not have the required permissions to view the files attached to this post.
An expensive day out: Wallet and Grimace

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Find a word and underline with color

Post by HansV »

Try this version:

Code: Select all

Sub HighlightStrings()
    
    Application.ScreenUpdating = False
    
    Dim Rng     As Range
    Dim cFnd    As String: cFnd = "believe"
    Dim xTmp    As String
    Dim x       As Long
    Dim m       As Long
    Dim y       As Long
    Dim c       As Long
    
    For Each Rng In Range("G2", Range("G" & Rows.Count).End(xlUp))
        With Rng
            xTmp = Rng.Value
            m = Len(xTmp)
            x = InStr(xTmp, cFnd)
            Do While x
                y = Len(cFnd)
                Do While x + y <= m
                    c = Asc(Mid(xTmp, x + y))
                    If c >= 97 And c <= 122 Then
                        y = y + 1
                    Else
                        Exit Do
                    End If
                Loop
                With Rng.Characters(Start:=x, Length:=y).Font
                    .Color = vbRed
                    .Underline = xlUnderlineStyleSingle
                End With
                x = InStr(x + y, xTmp, cFnd)
            Loop
        End With
    Next Rng
    
    Application.ScreenUpdating = True
    
End Sub
Best wishes,
Hans

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Find a word and underline with color

Post by HansV »

Chris, this question is about Excel, not Word...
Best wishes,
Hans

gailb
3StarLounger
Posts: 254
Joined: 09 May 2020, 14:00

Re: Find a word and underline with color

Post by gailb »

Thank you both Chris and Hans.

@Hans, that worked great. Thanks.

User avatar
ChrisGreaves
PlutoniumLounger
Posts: 15498
Joined: 24 Jan 2010, 23:23
Location: brings.slot.perky

Re: Find a word and underline with color

Post by ChrisGreaves »

HansV wrote:
29 Dec 2021, 20:43
Chris, this question is about Excel, not Word...
Here we go.

A self-testing function "LocateStrings" in module "modGailB"

Up to my usual standards:-
(a) Hastily assembled
(b) Incomplete
(c) Coded only for generic strings within a cell
(d) Tested once and assumed to be OK for eternity
(e) Poorly documented

I resolved the problem into two parts: (1) Locating the target sub-strings and (2) implementing the formatting.

I saw that the initial problem had generic substrings embedded within a cell, but considered that I should also consider specific substrings at the left-hand end of a cell string and at the right-hand end of a cell string. I did not code for the left and right-hand ends. Those CASE statements are empty.

I have never coded for “underline with colour”, so I decided any old local formatting would do (Bold, 32 pt)
For those of you who will protest that the previously supplied code was “not broken and did not need to be fixed” I would reply “I am a programmer” (grin)

Cheers
Chris
You do not have the required permissions to view the files attached to this post.
An expensive day out: Wallet and Grimace

gailb
3StarLounger
Posts: 254
Joined: 09 May 2020, 14:00

Re: Find a word and underline with color

Post by gailb »

Thanks Chris