finding exact text.

[CRogers]

Hello,

I have a spreadsheet an old colleague created where there is a macro that looks for key words. What I'm trying to do is fix it so that only catches exact words. i.e. I'm looking for "airman" and it picks up "chairman". I have the list of key words. Question : is there a way that I can make it only highlight if it says "airman"?

Thanks in advance for any help!

 

[Joe4]

Welcome to the Board!

What do your entries look like in the cells?
Are you matching the exact contents, i.e. the COMPLETE entry in the cell is "airman"?
Or might it be one word among many in the cells, i.e. "I am an airman"?

 

[CRogers]

Welcome to the Board!

What do your entries look like in the cells?
Are you matching the exact contents, i.e. the COMPLETE entry in the cell is "airman"?
Or might it be one word among many in the cells, i.e. "I am an airman"?

Thank you!

It is one word among many. The macro highlights the key word and then pull into another cell for keyword matches.

i.e. "Ted is the Chairman" it is reading "Ted is the Chairman"

 

[Joe4]

Can you post the VBA code to this macro you are using?

 

[CRogers]

Sub Run_Search()
Dim sLast, kLast As Long
Dim sRange, kRange, ktRange, finddatacolumn As Range
Dim matchedwords, temp, ktextstr As String
Dim res, intMatches, i, x, y, datacolumn As Integer
Dim tempArr, ktArr() As String
Dim scnt, areacnt As Integer
Dim colorArr() As String
Dim mycolor, thiscolor As String

mycolor = "255,16711680,16746752,16747007,35072,16771707,48383,48300,8406527,16762537"
colorArr = Split(mycolor, ",")
i = -1
x = 0
y = -1
temp = ""
tempArr = ""
areacnt = 0
Set finddatacolumn = Worksheets("Data").Range("A1:Z1").Find(What:="Client Complaint", LookIn:=xlValues, LookAt:=xlWhole, _
                    MatchCase:=False, SearchFormat:=False)
datacolumn = finddatacolumn.Column

sLast = Worksheets("data").Cells(Cells.Rows.Count, datacolumn).End(xlUp).Row
kLast = Worksheets("keywords").Cells(Cells.Rows.Count, "A").End(xlUp).Row
Worksheets("data").Range("I2:I10000").ClearContents
Worksheets("data").Range("D2:D10000").ClearContents
'Worksheets("data").Range("C2:C10000").ClearContents

'Set sRange = Worksheets("data").Range("A2:A" & sLast)
Set sRange = Worksheets("data").Range(Cells(2, datacolumn).Address, Cells(sLast, datacolumn))
Set kRange = Worksheets("keywords").Range("A2:A" & kLast)

For Each Item In kRange.Offset(0, 1)
    temp = Item.Value
    If InStr(tempArr, temp) = 0 Then
        If Len(tempArr) > 0 Then
            tempArr = tempArr + "||" + temp
        Else
            'MsgBox temp & "  " & Item.Offset(0, -1)
            If Len(temp) > 0 Then
                tempArr = temp
            Else
                tempArr = tempArr + "||" + "Empty"
            End If
        End If
    ElseIf Len(temp) = 0 Then
        tempArr = tempArr + "||" + "Empty"
    End If
Next Item
'MsgBox tempArr

x = 1
If Len(tempArr) > 0 Then
    ktArr = Split(tempArr, "||")
    If UBound(ktArr) <= 10 Then
        For Each hh In ktArr
            i = i + 1
            ktArr(i) = hh + "||" + colorArr(i)
            Worksheets("data").Cells(x + i + 1, datacolumn + 7).Value = hh
            Worksheets("data").Cells(x + i + 1, datacolumn + 7).Font.Color = colorArr(i)
        Next hh

        i = 0
        x = 0
    Else
        MsgBox ("You have more than 10 different types of Loan terms on the Keywords sheet, You can only have up to 10 different term types, Change Term Types and try again")
        Exit Sub
    End If
   
End If
'MsgBox Join(ktArr)
For Each stxt In sRange
    stxt.Font.Color = vbBlack
    stxt.Offset(0, 2).Value = ""
    stxt.Offset(0, 3).Value = ""
    If Len(stxt.Value) > 0 Then
        matchedwords = ""
        matchedareas = ""
        y = -1
        For Each ktxt In kRange
            res = InStr(LCase(stxt), LCase(ktxt))
            If res > 0 Then
                intMatches = intMatches + 1
                If Len(Join(ktArr)) > 0 Then
                    For Each x In ktArr
                      If InStr(ktxt.Offset(0, 1).Value, Split(x, "||")(0)) > 0 Or Len(ktxt.Offset(0, 1).Value) = 0 Then
                        y = y + 1
                        thiscolor = Split(x, "||")(1)
                        Exit For
                      'Else
                      '  thiscolor = Split(x, "||")(1)
                      '  MsgBox x
                      '  thiscolor = colorArr(9)
                      End If
                    Next x
                Else
                    thiscolor = colorArr(9)
                End If
                'MsgBox thiscolor
               
                done = highlight(stxt.Value, ktxt.Value, stxt.Cells, CLng(thiscolor))
                matchedwords = matchedwords & ktxt.Value & " (" & Str(done) & "), "
                If InStr(matchedareas, ktxt.Offset(0, 2).Value & " / ") = 0 Then
                    areacnt = areacnt + 1
                    matchedareas = matchedareas & ktxt.Offset(0, 2).Value & " / "
                End If
                stxt.Offset(0, 2).Value = matchedwords
                stxt.Offset(0, 3).Value = matchedareas
                stxt.Offset(0, 4).Value = intMatches
            End If
        Next ktxt
        If areacnt > 0 Then
            temptxt = stxt.Offset(0, 3).Value
            stxt.Offset(0, 3).Value = Left(temptxt, (Len(temptxt) - 3))
        End If
        areacnt = 0
       
    End If
intMatches = 0
Next stxt
MsgBox "Done"
Set sRange = Nothing
Set kRange = Nothing

End Sub

Function highlight(stxt As String, ftxt As String, sCell As Range, thiscolor As Long)
    Dim x As Integer
    Dim ptr As Integer
    Dim found As Integer
    found = 0
    x = 0
    stxt = sCell.Value
    ptr = InStr(LCase(stxt), LCase(ftxt))
    Do While ptr > 0
       With sCell.Characters(ptr, Len(ftxt))
        .Font.Color = thiscolor
       End With
       found = found + 1
       ptr = InStr(ptr + Len(ftxt), LCase(stxt), LCase(ftxt))
    Loop
    highlight = found
End Function

 

[Joe4]

Wow, that is some monster code! I am not going to even try to evaluate that, especially since I don't have all the structure and data on the sheet that it refers to.

The issue is this:
You could check for a space before and after the word, i.e. " airman ".
But what if it is the first word in the string (so there is nothing before it).
Or if there is punctuation after it?

You need to create some really smart code that checks for all these options.
Or you could search for code that someone else may have created that already does this.
Here is one that I found: VBA Code to Find a Whole Word in a Statement

 

[CRogers]

Thank you so much for your time. I don't have a lot of experience with VBA but will take a look.

Thank you again.

 

[Joe4]

You are welcome.

Yeah, what you want to do is very tricky.
It is easy to check to see if the value is contained anywhere in the string, like the original code does now.
And it is easy to check if the ENTIRE string equals exactly what you are looking for.
But it is much harder to look a word in a bigger string, and to exclude where it may be contained in a longer word (like "airman" in "chairman").

 

[Scott Huish]

Why don't you just use Conditional Formatting?

If your list of words in Column I and your words to search in in Column A

Conditional Formatting formula:
=OR(ISNUMBER(FIND(" " &$I$1:$I$1000&" "," "&A1&" ")))

Book2
	A	B	C	D	E	F	G	H	I
1	The chairman is here								airman
2	I saw the airman								pilot
3	The funny papers are cool								fun
Sheet1

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A:A	Expression	=OR(ISNUMBER(FIND(" " &$I$1:$I$1000&" "," "&A1&" ")))	text	NO

 

[Akuini]

Try using regex:

Sub CRogers_1()
Sub CRogers_1()
Dim regEx As Object, Matches As Object, M
Dim c As Range
Dim x, va
va = Range("A2", Cells(Rows.Count, "A").End(xlUp)) 'keyword list

Application.ScreenUpdating = False
        Set regEx = CreateObject("VBScript.RegExp")
        With regEx
                .Global = True
                .IgnoreCase = True 'case insensitive
            For Each x In va
                .Pattern = "\b" & x & "\b"
                For Each c In Range("B2", Cells(Rows.Count, "B").End(xlUp))  'data
                    If .test(c) Then
                           Set Matches = .Execute(c)
                        For Each M In Matches
                             c.Characters(M.FirstIndex + 1, M.Length).Font.Color = vbRed  'red
'                             c.Characters(M.FirstIndex + 1, M.Length).Font.Bold = True
                        Next M
                    End If
                Next
            Next
        End With
Application.ScreenUpdating = True
End Sub

Example:

CRogers - regex.xlsm
	A	B
1	LIST	DATA
2	car	scarf in the car
3	apple	Car & car & card
4		apple & car wash
5		Apples & apple
Sheet1

Result: