VBA Help: Macro finds text string, but need it to find whole words ONLY

[jholly1984]

Hi there, and thank you in advance for helping me with this!

I have a previous macro that I received help with a few years ago which has been serving me well: Original Solution's Post

However, I'm running into trouble with the accuracy. Essentially, if my list of modifier words to be found has short words that can be partial matches to other words, it returns the longer words as though they match the words being found in the cells. For example, if I use the word "car" or "id" or "ai", expecting only cells that contain those words.

Sub Maybe()
Dim c As Range, i As Long, sh1 As Worksheet
Application.ScreenUpdating = False
Set sh1 = Worksheets("data")    '<-----Sheet with all the data. Change as required
Set sh2 = Worksheets("modifiers")    '<-----Sheet with all the modifiers. Change as required
    For Each c In sh2.Range("a2:a114")
    If Not [ISREF(c.Value!A1)] Then Sheets.Add(, Sheets(Sheets.Count)).Name = c.Value
        For i = 2 To sh1.Cells(Rows.Count, 4).End(xlUp).Row
            If InStr(sh1.Cells(i, 4), c) > 0 Then
                With Sheets(c.Value)
                    .Cells(1, 1).Resize(, 9).Value = sh1.Cells(1, 1).Resize(, 9).Value
                    .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 9).Value = sh1.Cells(i, 1).Resize(, 9).Value
                End With
            End If
        Next i
    Next c
Sheets("data").Select    '<-----Sheet with all the data. Change as required
Application.ScreenUpdating = True
End Sub

When the modifier is "car" I only expect it to return cells that have "car" (i.e. "car wash", "race car", "driving my car on a rainy day" - which it does!) but it also returns cells that contain longer variations (i.e. "cardstock", "carson", "take the streetcar to the second stop").

I've tried using spaces in front/behind the words, but then I don't capture instances where the cell starts or ends with the modifier word in question. I've tried adding a single or double quote in front and behind each word in the list, but that doesn't seem to work either.

Any help you can provide would be HUGELY appreciated!

 

[Tom Urtis]

Well, if you want to highlight the word of interest ("car" per your example) among text you can try this.

Option Compare Text 'Highlight Earnings and earnings.

Sub HighlightWord()

'Declare variables.
Dim i%, strText$, strWord$, Cell As Range
strWord = "car"

'Format all cells as black font, unbolded.
With Columns(1).SpecialCells(2).Font
.Bold = False: .Color = vbBlack
End With

'Loop through each cell holding a constant value.
'Examine each character for what to highlight,
'example "car".
For Each Cell In ActiveSheet.UsedRange.SpecialCells(2)
With Cell
strText = .Text

If Right(strText, Len(strWord)) = strWord Then
With .Characters(.Characters.Count - Len(strWord) + 1, _
Len(strWord)).Font
.Color = vbRed
.Bold = True
End With
End If

If InStr(strText, strWord) > 0 Then
'Highlight the found word
For i = 1 To Len(strText) - Len(strWord) + 1
'For i = 1 To Len(strText) - Len(strWord) Step 1
If Mid(strText, i, Len(strWord)) = strWord Then
.Characters(i, Len(strWord)).Font.Color = vbRed
.Characters(i, Len(strWord)).Font.Bold = True
End If: Next i

End If: End With: Next Cell
End Sub

 

[jholly1984]

Well, if you want to highlight the word of interest ("car" per your example) among text you can try this.

Option Compare Text 'Highlight Earnings and earnings.

Sub HighlightWord()

'Declare variables.
Dim i%, strText$, strWord$, Cell As Range
strWord = "car"

'Format all cells as black font, unbolded.
With Columns(1).SpecialCells(2).Font
.Bold = False: .Color = vbBlack
End With

'Loop through each cell holding a constant value.
'Examine each character for what to highlight,
'example "car".
For Each Cell In ActiveSheet.UsedRange.SpecialCells(2)
With Cell
strText = .Text

If Right(strText, Len(strWord)) = strWord Then
With .Characters(.Characters.Count - Len(strWord) + 1, _
Len(strWord)).Font
.Color = vbRed
.Bold = True
End With
End If

If InStr(strText, strWord) > 0 Then
'Highlight the found word
For i = 1 To Len(strText) - Len(strWord) + 1
'For i = 1 To Len(strText) - Len(strWord) Step 1
If Mid(strText, i, Len(strWord)) = strWord Then
.Characters(i, Len(strWord)).Font.Color = vbRed
.Characters(i, Len(strWord)).Font.Bold = True
End If: Next i

End If: End With: Next Cell
End Sub

Thanks, Tom.

I still need it to fulfill the additional steps of copying the line of data to a new sheet with the tab named with the word in question... I'm just looking for it to find the exact string without any additional characters before or after (though there CAN be other words in the cell). Does that make sense? (It's somewhat difficult to describe... Exact match for the word in the cell but not for the cell as a whole).

 

[DanteAmor]

Try this:

Sub Maybe()
  Dim c As Range, i As Long
  Dim sh1 As Worksheet, sh2 As Worksheet
 
  Application.ScreenUpdating = False
  Set sh1 = Worksheets("data")          '<-----Sheet with all the data. Change as required
  Set sh2 = Worksheets("modifiers")     '<-----Sheet with all the modifiers. Change as required
  For Each c In sh2.Range("A2", sh2.Range("A" & Rows.Count).End(3))
    If Not Evaluate("ISREF('" & c.Value & "'!A1)") Then
      Sheets.Add(, Sheets(Sheets.Count)).Name = c.Value
      Sheets(c.Value).Cells(1, 1).Resize(, 9).Value = sh1.Cells(1, 1).Resize(, 9).Value
    End If
    For i = 2 To sh1.Cells(Rows.Count, 4).End(xlUp).Row
      If InStr(1, " " & sh1.Cells(i, 4) & " ", " " & c.Value & " ", vbTextCompare) > 0 Then
        Sheets(c.Value).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 9).Value = sh1.Cells(i, 1).Resize(, 9).Value
      End If
    Next i
  Next c
  sh1.Select
  Application.ScreenUpdating = True
End Sub

There will also be punctuation to consider, for example, if the sentence ends with "race car." then we will have to replace in the comparison "." by space " "

Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --

 

[jholly1984]

Try this:

Sub Maybe()
  Dim c As Range, i As Long
  Dim sh1 As Worksheet, sh2 As Worksheet
 
  Application.ScreenUpdating = False
  Set sh1 = Worksheets("data")          '<-----Sheet with all the data. Change as required
  Set sh2 = Worksheets("modifiers")     '<-----Sheet with all the modifiers. Change as required
  For Each c In sh2.Range("A2", sh2.Range("A" & Rows.Count).End(3))
    If Not Evaluate("ISREF('" & c.Value & "'!A1)") Then
      Sheets.Add(, Sheets(Sheets.Count)).Name = c.Value
      Sheets(c.Value).Cells(1, 1).Resize(, 9).Value = sh1.Cells(1, 1).Resize(, 9).Value
    End If
    For i = 2 To sh1.Cells(Rows.Count, 4).End(xlUp).Row
      If InStr(1, " " & sh1.Cells(i, 4) & " ", " " & c.Value & " ", vbTextCompare) > 0 Then
        Sheets(c.Value).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 9).Value = sh1.Cells(i, 1).Resize(, 9).Value
      End If
    Next i
  Next c
  sh1.Select
  Application.ScreenUpdating = True
End Sub

There will also be punctuation to consider, for example, if the sentence ends with "race car." then we will have to replace in the comparison "." by space " "

Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --

Thank you for your help! This definitely does eliminate the problem with finding the exact word and not a variation, but it does not identify the word if it is the first or last word in the cell. Any ideas on how I can accommodate that?

Thanks Dante!!!

 

[DanteAmor]

but it does not identify the word if it is the first or last word in the cell.

In my tests the following examples work fine:

(i.e. "car wash", "race car", "driving my car on a rainy day"

You can put here which examples don't work, what you have in the "data" sheet and what you have in the "modifiers" sheet.