Highlight row if cell contains string from seprate user generated list

[Tiny]

Hi Folks

I'm looking for some help with 500K + lines of data over several workbooks, (and a buch of non-techie users).

After lots of searches I've found a few 'parts' that help, but have got myself confused with trying to put them together and the different ways of doing the same thing.

In a nutshell I want to enable users to put a list of keyword strings (list) specific to their needs into column A Sheet1 (Keywords)

Start a search were the strings in the list are used to search the 'data' (sheet2), where the column which will contain the keyword varies from workbook to workbook (not usually bigger column V).

If the string is found highlight the entire row. The user can then visually review the search hit (along with a few rows above and below if required).
{It woud be a bonus (but not required) if the actual hit row was one collour (red?) and ~6 rows either side were another colour (yellow?).}

Ultimately, my plan for the future is to set up a master copy sheet where users can paste into the 'data sheet' and add their search terms to the 'keywords' sheet, run the search and take away the results to study them.

I've adapted the below code below but his is as far as I've got before I blew my fuse I seem to have got in an 'intersect' rut but I'm not sure is the right way to go.

Public Sub HighlightListedValues()
    Dim keywordList As String
    Dim Cell As Range

    'Creates a string concatenating your list of strings, separated by |s
    'e.g. "item1|item2|item3|item4|"
    For Each Cell In Sheets("keywords").Range("A2:A7") ' Needs to be variable!  [COLOR=#333333]?[FONT=Segoe UI]columns.Count, a.End(xlUp)?[/FONT][/COLOR]
        keywordList = keywordList & Cell.Value & "|"
    Next Cell

    'For each used cell in Column A of sheet1, check whether the value in that cell
    'is contained within the concatenated string
    For Each Cell In Intersect(Sheets("data").Range("H:H"), Sheets("data").UsedRange) 'H changes in other sheets
        If InStr(keywordList, Cell.Value) > 0 Then       'InStr returns 0 if the string isn't found
            Cell.EntireRow.Interior.Color = RGB(255, 0, 0) 'Highlights the row in red if value found
        End If
    Next Cell
End Sub

 

[jbuist]

Hello!

I have a similar issue when I happened upon this thread. It seems to solve most of my needs, but it's not highlighting *all* of the keywords in the list. I modified Peter's code (deleted a little, changed color to green), but can't figure out why it's not highlight all of the keywords in my "list". I have 30+ keywords I am trying to check/highlight. Any insight to the code listed below is appreciated. I am a beginner when it comes to VBA.

Thank you!!!!

Sub HighlightKeywords()
Dim wsL As Worksheet, wsD As Worksheet
Dim aData As Variant, aColr As Variant
Dim fr As Long, lr As Long, r As Long, i As Long, ubD As Long, nc As Long
Dim rCol As Range, rData As Range
Dim RX As Object

Set wsL = Sheets("list")
Set wsD = Sheets("DATA")
Set RX = CreateObject("VBScript.RegExp")
RX.IgnoreCase = True
RX.Pattern = "\b(" & Join(Application.Transpose(wsL.Range("A2", wsL.Range("A" & wsL.Rows.Count).End(xlUp)).Value), "|") & ")\b"
With wsD
.Cells.Interior.Color = xlNone
.Activate
Set rCol = .Range("A1:B1")
On Error Resume Next
Set rCol = Application.InputBox(Prompt:="Select any cells in the data column to be checked", Default:=ActiveCell.Address, Type:=8)
On Error GoTo 0
If rCol.Columns.Count = 1 Then
Application.ScreenUpdating = False
nc = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, SearchFormat:=False).Column + 1
Set rData = .Range(.Cells(2, rCol.Column), .Cells(.Rows.Count, rCol.Column).End(xlUp))
aData = rData.Value
ubD = UBound(aData)
ReDim aColr(1 To ubD, 1 To 2)
fr = 1
For i = 1 To ubD
aColr(i, 2) = i
If RX.Test(aData(i, 1)) Then
If i > fr + 6 Then fr = i - 6
lr = i + 6
If lr > ubD Then lr = ubD
For r = fr To lr
aColr(r, 1) = 1
Next r
aColr(i, 1) = "a"
fr = i + 1
End If
Next i
With .Range("A2").Resize(ubD, nc + 1)
.Columns(nc).Resize(, 2).Value = aColr
.Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
On Error Resume Next
.Columns(nc).SpecialCells(xlConstants, xlTextValues).EntireRow.Resize(, nc - 1).Interior.Color = vbGreen
On Error GoTo 0
.Sort Key1:=.Columns(nc + 1), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
.Columns(nc).Resize(, 2).ClearContents
End With
Application.ScreenUpdating = True
End If
End With
End Sub

 

[Peter_SSs]

I have a similar issue ...

I have answered in your own thread. In future, please do not post the same question multiple times. Refer to #12 of the Forum Rules and points 6 & 7 of the Forum Use Guidelines.