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

 

[RCBricker]

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

ok we might need to do this piecemeal

first change your code to the following above the first loop to this (keep your dims):

    Dim rngLIST As Range
    Dim lngROWL As Long
    
    'first lets set our range to make things easier
    lngROWL = Range("A" & .Rows.Count).End(xlUp).Row
    Set rngLIST = Range("A2:A" & lngROWL)
    
    'Creates a string concatenating your list of strings, separated by |s
    'e.g. "item1|item2|item3|item4|"
    For Each Cell In rngLIST ' Needs to be variable!  ?columns.Count, a.End(xlUp)?
        keywordList = keywordList & Cell.Value & "|"
    Next Cell

this adds new dims and changes your first loop

We are setting the last row of data for the list and then setting the whole list to a range variable.

now onto some questions.

1. It might be easier to know what the header of column H is and whether that header title is used on the other workbooks

2. Are all of the workbooks in the same folder?
2A. what is the naming convention of the workbooks

3. is all the data on sheets with the same names?

What we are going to need is logical answers that we can then translate into code. The end result as I see it will be to check Sheets("data") for the data, then open each workbook and check Sheets(" what ever the name is"),etc.

When the rows are found, to Highlight the entire data of that row *pick your color*

then Highlight 6 rows above and 6 rows below (or is there a logical reason up or down) a different color *pick your color*

or:
copy the data and insert it into a new worksheet/workbook so the user can take the data with them.

sound about right?

 

[Tiny]

Thanks for the quick response RCBricker.

The 'debug compiler' has a problem with

lngROWL = Range("A" & .Rows.Count).End(xlUp).Row

.Rows is highlighted and error reads 'invalid or unqualified reference' I'm guessing its looking for; 'sheet("keywords")' some where?

to answer your questions...

1. 'output message' but it changes accross the sheets, hence me trying to make it as generic as poss.

2. No but they can be.
2a. Again no ... various data dumps, which are also going to change in teh next few weeks/months.
(this is why I was I want to sent up a 'master sheet' so users can drop the data into it and define their own search words)

3. No... see above, they are given a reference from the original data dump some have date codes etc. some don't.

The reason the user (engineer) needs to review the output in the context of a few rows BOTH sides is that it gives them an idea why the string (machine error code) might have occured to then go and fix it.

I've asked about copying 'parts' out to another workbook but they want the whole thing, so they can read more than 6 lines IF needed to get further clues as to why/how an error occured, so it needs to stay in the original sheet.

 

[RCBricker]

Thanks for the quick response RCBricker.

The 'debug compiler' has a problem with

lngROWL = Range("A" & .Rows.Count).End(xlUp).Row

.Rows is highlighted and error reads 'invalid or unqualified reference' I'm guessing its looking for; 'sheet("keywords")' some where?

to answer your questions...

1. 'output message' but it changes accross the sheets, hence me trying to make it as generic as poss.

2. No but they can be.
2a. Again no ... various data dumps, which are also going to change in teh next few weeks/months.
(this is why I was I want to sent up a 'master sheet' so users can drop the data into it and define their own search words)

3. No... see above, they are given a reference from the original data dump some have date codes etc. some don't.

The reason the user (engineer) needs to review the output in the context of a few rows BOTH sides is that it gives them an idea why the string (machine error code) might have occured to then go and fix it.

I've asked about copying 'parts' out to another workbook but they want the whole thing, so they can read more than 6 lines IF needed to get further clues as to why/how an error occured, so it needs to stay in the original sheet.

first the error

replace that line with the following

    Dim ws As Worksheet
    
    Set ws = ActiveSheet
    
    'first lets set our range to make things easier
    lngROWL = Range("A" & ws.Rows.Count).End(xlUp).Row

As for the rest. Man you sure are not making this easy.

Will an user know the column name that needs to be checked on sight? How do we tell excel to check a specific column if not? Technically I can write the code to look for the data on the entire sheet and still do what you want it do. It would then activate that workbook and the cell that contains the data.

If we have to do it that way, then I would suggest an open file sub that allows the user to check which file to open. The code would open the file and do the search. IF nothing is found it would close the file and a message box that nothing was found. IF it is found, color the cells, activate the workbook and select the cell with the data for review.

When the user finishes their review of that workbook. They would have to close it with out saving it. Then run the code and select the next workbook.

IF THE USER CAN PICK OUT THE COLUMN...

I can write code that will open the workbook and then display a drop down list populated with all the header names and they would be asked to select the column. And the code runs from there just as it would with out their interaction.

I would go with the first solution no matter what as it is safer. If the user selects the wrong column they could get a false negative.

Regards

 

[RCBricker]

Ok lets try out some code

Public Sub HighlightListedValues()
    Dim keywordList As String
    Dim Cell As Range
    Dim rngLIST As Range, rngCOLORup As Range, rngCOLORdown As Range
    Dim lngROWL As Long, lngCOL As Long
    Dim wsLIST As Worksheet, wsDATA As Worksheet
    Dim wb1 As Workbook
    Dim varI As Variant, varJ As Variant
    Dim MSG1 As Variant, varH As Variant
    
    Set wb1 = ThisWorkbook
    Set wsLIST = Sheets("list")
    
    'first lets set our range to make things easier
    lngROWL = Range("A" & wsLIST.Rows.Count).End(xlUp).Row
    Set rngLIST = wsLIST.Range("A2:A" & lngROWL)
    
    For Each Cell In rngLIST
        keywordList = keywordList & Cell.Value & "|"
    Next Cell
    Set wsDATA = Sheets("DATA")
    lngCOL = 8
    Set rngLIST = Range(wsDATA.Cells(1, lngCOL), wsDATA.Cells(lngROWL, lngCOL)) 'H changes in other sheets
    'For each used cell in Column A of sheet1, check whether the value in that cell
    'is contained within the concatenated string
    wsDATA.Select
    With wsDATA
    For Each Cell In rngLIST
        If InStr(keywordList, Cell.Value) > 0 Then       'InStr returns 0 if the string isn't found

                If Cell.Row < 6 Then
                    varJ = 1
                Else
                    varJ = Cell.Row - 6
                End If
                Set rngCOLORup = Range(.Cells(varJ, Cell.Column), _
                    .Cells(Cell.Offset(-1).Row, Cell.Column))
                For Each varI In rngCOLORup
                    If Not varI.Interior.Color = RGB(255, 0, 0) Then
                        varI.EntireRow.Interior.Color = RGB(255, 255, 0)
                    End If
                Next varI
                
                If Cell.Row + 6 > lngROWL Then
                    varJ = lngROWL
                Else
                    varJ = Cell.Row + 6
                End If
                Set rngCOLORdown = Range(.Cells(Cell.Offset(1).Row, Cell.Column), _
                    .Cells(varJ, Cell.Column))
                rngCOLORdown.EntireRow.Interior.Color = RGB(255, 255, 0)
                Cell.EntireRow.Interior.Color = RGB(255, 0, 0) 'Highlights the row in red if value found
            End If
    Next Cell
    End With
    
    For varH = 1 To 10000
        MSG1 = MsgBox("Open a File to Search", vbYesNo, "Open another file?")
        If MSG1 = vbYes Then
            Call Search_Keywordlist(keywordList)
        Else
            Exit For
        End If
    Next
End Sub

Sub Search_Keywordlist(keywordList As String)

    Dim Cell As Range
    Dim rng As Range, rngCOLORup As Range, rngCOLORdown As Range
    Dim lngROWL As Long, lngROW As Long, lngCOL As Long
    Dim wsLIST As Worksheet, wsDATA As Worksheet
    Dim wb2 As Workbook
    Dim varI As Variant, varJ As Variant
    Dim strWSNAME
    

        Call OPEN_EXCEL
        Set wb2 = ActiveWorkbook
        If wb2.Worksheets.Count > 1 Then
            strWSNAME = InputBox("Please type in the worksheet name to search.", "Worksheet Name?")
            Set wsDATA = Sheets(strWSNAME)
        Else
            Set wsDATA = ActiveSheet
        End If
        wsDATA.Select
        With wsDATA
            lngROW = LASTROW
            lngCOL = LASTCOL
        
            Set rng = Range(.Cells(1, 1), .Cells(lngROW, lngCOL))

        For Each Cell In rng
            If InStr(keywordList, Cell.Value) > 0 Then       'InStr returns 0 if the string isn't found
    
                    If Cell.Row < 6 Then
                        varJ = 1
                    Else
                        varJ = Cell.Row - 6
                    End If
                    Set rngCOLORup = Range(.Cells(varJ, Cell.Column), _
                        .Cells(Cell.Offset(-1).Row, Cell.Column))
                    For Each varI In rngCOLORup
                        If Not varI.Interior.Color = RGB(255, 0, 0) Then
                            varI.EntireRow.Interior.Color = RGB(255, 255, 0)
                        End If
                    Next varI
                    
                    If Cell.Row + 6 > lngROW Then
                        varJ = lngROW
                    Else
                        varJ = Cell.Row + 6
                    End If
                    Set rngCOLORdown = Range(.Cells(Cell.Offset(1).Row, Cell.Column), _
                        .Cells(varJ, Cell.Column))
                    rngCOLORdown.EntireRow.Interior.Color = RGB(255, 255, 0)
                    Cell.EntireRow.Interior.Color = RGB(255, 0, 0) 'Highlights the row in red if value found
                End If
        Next Cell
        End With


End Sub

Public Sub OPEN_EXCEL()
Dim fDIAL As FileDialog
Dim strSPECIAL As String
Dim wbOPEN As Workbook

On Error GoTo ErrCapture

    Set fDIAL = appEXCEL.FileDialog(msoFileDialogFilePicker)
    With fDIAL
        .AllowMultiSelect = False
        .Title = "Please select a file"
        .Filters.Clear
        .Filters.Add "Excel", "*.xls*"
        If .Show = True Then
            strSPECIAL = .SelectedItems(1)
        Else

            MsgBox "User Selected CANCEL." & vbNewLine & "  Please start over!"
            Exit Sub
        End If
    End With

On Error Resume Next
    Set wbOPEN = Workbooks.Open(strSPECIAL)
On Error GoTo ErrCapture

End Sub
Public Function LASTROW()
Dim rngLROW As Range
Dim ws As Worksheet
Dim lngROWS As Long

    Set ws = ActiveSheet
    Set rngLROW = ws.Cells

    lngROWS = rngLROW.Find(What:="*", _
        after:=rngLROW.Cells(1), _
        LOOKAT:=xlPart, _
        LookIn:=xlFormulas, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Row
    LASTROW = lngROWS
End Function
Public Function LASTCOL()
Dim rngLCOL As Range
Dim ws As Worksheet
Dim lngCOLS As Long

    Set ws = ActiveSheet
    Set rngLCOL = ws.Cells

    lngCOLS = rngLCOL.Find(What:="*", _
        after:=rngLCOL.Cells(1), _
        LOOKAT:=xlPart, _
        LookIn:=xlFormulas, _
        SearchOrder:=xlByColumns, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Column
    LASTCOL = lngCOLS
End Function

So this will take care of the first workbook and then it will ask if the user wants to open another workbook. It will then search that workbook, then it will ask again... it will loop until the user says NO to the question as to whether they wish to open another workbook.

The code during the search will highlight the entire row of any row whose value is found with in the keywordlist string.

It will highlight as many as 6 rows above in yellow and as many as 6 rows below in yellow...IF and only IF the row is not already colored red.

The only issue I have is that I had to set it so the user has to type in the name of the worksheet in the newly opened workbook IF and ONLY IF that workbook has more than one worksheet.

Let me know how it works

Regards

 

[Tiny]

Thanks, that fixed the error.

As for the rest. Man you sure are not making this easy.

I know I'm sorry. If it helps any, if I can give them access to a 'blank master' XLSM workbook, the guy(s) ARE capable of copying & pasting the data into the sheet and type the 'keywords' list themselves.

They will easily recognise the column they need to read from, it's simply the number of lines they need to go through without missing the keyword 'clues', so there's no need to pick it out in the VBA. (the other columns report WHERE the 'message output' came from)

I think you're right about the first solution, adding a dropdown column selector may complicate things at this stage.
(However it might be useful for the next generation of software, data dumps we get, as the output will be much wider, with more headings).

About automatically opening sheets from a folder, again we could manage without that functionality. I am the one who exports the raw data to the 1st spreadsheet, to pass it on to the engineers, so we'll know which ones we need from the outset. They will also need to be able to save (save as) the Workbooks with the errors highlighted, for future reference.

Hope this makes it easier

Thanks Again

 

[RCBricker]

Thanks, that fixed the error.



I know I'm sorry. If it helps any, if I can give them access to a 'blank master' XLSM workbook, the guy(s) ARE capable of copying & pasting the data into the sheet and type the 'keywords' list themselves.

They will easily recognise the column they need to read from, it's simply the number of lines they need to go through without missing the keyword 'clues', so there's no need to pick it out in the VBA. (the other columns report WHERE the 'message output' came from)

I think you're right about the first solution, adding a dropdown column selector may complicate things at this stage.
(However it might be useful for the next generation of software, data dumps we get, as the output will be much wider, with more headings).

About automatically opening sheets from a folder, again we could manage without that functionality. I am the one who exports the raw data to the 1st spreadsheet, to pass it on to the engineers, so we'll know which ones we need from the outset. They will also need to be able to save (save as) the Workbooks with the errors highlighted, for future reference.

Hope this makes it easier

Thanks Again

did you test the full code I gave?

 

[Tiny]

did you test the full code I gave?

WOW great start....The colouring is working perfectly, .It's finding some of keywords (whole cell contents) AND and it seems to be ignoring some stray random illegal characters, such as '�F�' which I was worried about. (heaven only knows where they've come from).

The problem seems to be that it's picking up single characters from the indivividual strings (e.g. keyword " C2C " its picking up " 2 " - which is a separate error code).

Some of the keywords seem to being missed where they appear in amongst other 'text' (e.g. keyword " Table " from an entry that reads " Table: (id: 72) "

" ? " are also being picked up (in the free text notes column).


The 'Public Sub OPEN_EXCEL()' module won't get past.
'On Error GoTo ErrCapture' (Label not defined)


I've prepared a simplified small sample (300 lines) as a test bed if it would help?.....

 

[RCBricker]

WOW great start....The colouring is working perfectly, .It's finding some of keywords (whole cell contents) AND and it seems to be ignoring some stray random illegal characters, such as '�F�' which I was worried about. (heaven only knows where they've come from).

The problem seems to be that it's picking up single characters from the indivividual strings (e.g. keyword " C2C " its picking up " 2 " - which is a separate error code).

Some of the keywords seem to being missed where they appear in amongst other 'text' (e.g. keyword " Table " from an entry that reads " Table: (id: 72) "

" ? " are also being picked up (in the free text notes column).


The 'Public Sub OPEN_EXCEL()' module won't get past.
'On Error GoTo ErrCapture' (Label not defined)


I've prepared a simplified small sample (300 lines) as a test bed if it would help?.....

fixed the error line issue

Public Sub HighlightListedValues()
    Dim keywordList As String
    Dim Cell As Range
    Dim rngLIST As Range, rngCOLORup As Range, rngCOLORdown As Range
    Dim lngROWL As Long, lngCOL As Long
    Dim wsLIST As Worksheet, wsDATA As Worksheet
    Dim wb1 As Workbook
    Dim varI As Variant, varJ As Variant
    Dim MSG1 As Variant, varH As Variant
    
    Set wb1 = ThisWorkbook
    Set wsLIST = Sheets("list")
    
    'first lets set our range to make things easier
    lngROWL = Range("A" & wsLIST.Rows.Count).End(xlUp).Row
    Set rngLIST = wsLIST.Range("A2:A" & lngROWL)
    
    For Each Cell In rngLIST
        keywordList = keywordList & Cell.Value & "|"
    Next Cell
    Set wsDATA = Sheets("DATA")
    lngCOL = 8
    Set rngLIST = Range(wsDATA.Cells(1, lngCOL), wsDATA.Cells(lngROWL, lngCOL)) 'H changes in other sheets
    'For each used cell in Column A of sheet1, check whether the value in that cell
    'is contained within the concatenated string
    wsDATA.Select
    With wsDATA
    For Each Cell In rngLIST
        If InStr(keywordList, Cell.Value) > 0 Then       'InStr returns 0 if the string isn't found

                If Cell.Row < 6 Then
                    varJ = 1
                Else
                    varJ = Cell.Row - 6
                End If
                Set rngCOLORup = Range(.Cells(varJ, Cell.Column), _
                    .Cells(Cell.Offset(-1).Row, Cell.Column))
                For Each varI In rngCOLORup
                    If Not varI.Interior.Color = RGB(255, 0, 0) Then
                        varI.EntireRow.Interior.Color = RGB(255, 255, 0)
                    End If
                Next varI
                
                If Cell.Row + 6 > lngROWL Then
                    varJ = lngROWL
                Else
                    varJ = Cell.Row + 6
                End If
                Set rngCOLORdown = Range(.Cells(Cell.Offset(1).Row, Cell.Column), _
                    .Cells(varJ, Cell.Column))
                rngCOLORdown.EntireRow.Interior.Color = RGB(255, 255, 0)
                Cell.EntireRow.Interior.Color = RGB(255, 0, 0) 'Highlights the row in red if value found
            End If
    Next Cell
    End With
    
    For varH = 1 To 10000
        MSG1 = MsgBox("Open a File to Search", vbYesNo, "Open another file?")
        If MSG1 = vbYes Then
            Call Search_Keywordlist(keywordList)
        Else
            Exit For
        End If
    Next
End Sub

Sub Search_Keywordlist(keywordList As String)

    Dim Cell As Range
    Dim rng As Range, rngCOLORup As Range, rngCOLORdown As Range
    Dim lngROWL As Long, lngROW As Long, lngCOL As Long
    Dim wsLIST As Worksheet, wsDATA As Worksheet
    Dim wb2 As Workbook
    Dim varI As Variant, varJ As Variant
    Dim strWSNAME
    

        Call OPEN_EXCEL
        Set wb2 = ActiveWorkbook
        If wb2.Worksheets.Count > 1 Then
            strWSNAME = InputBox("Please type in the worksheet name to search.", "Worksheet Name?")
            Set wsDATA = Sheets(strWSNAME)
        Else
            Set wsDATA = ActiveSheet
        End If
        wsDATA.Select
        With wsDATA
            lngROW = LASTROW
            lngCOL = LASTCOL
        
            Set rng = Range(.Cells(1, 1), .Cells(lngROW, lngCOL))

        For Each Cell In rng
            If InStr(keywordList, Cell.Value) > 0 Then       'InStr returns 0 if the string isn't found
    
                    If Cell.Row < 6 Then
                        varJ = 1
                    Else
                        varJ = Cell.Row - 6
                    End If
                    Set rngCOLORup = Range(.Cells(varJ, Cell.Column), _
                        .Cells(Cell.Offset(-1).Row, Cell.Column))
                    For Each varI In rngCOLORup
                        If Not varI.Interior.Color = RGB(255, 0, 0) Then
                            varI.EntireRow.Interior.Color = RGB(255, 255, 0)
                        End If
                    Next varI
                    
                    If Cell.Row + 6 > lngROW Then
                        varJ = lngROW
                    Else
                        varJ = Cell.Row + 6
                    End If
                    Set rngCOLORdown = Range(.Cells(Cell.Offset(1).Row, Cell.Column), _
                        .Cells(varJ, Cell.Column))
                    rngCOLORdown.EntireRow.Interior.Color = RGB(255, 255, 0)
                    Cell.EntireRow.Interior.Color = RGB(255, 0, 0) 'Highlights the row in red if value found
                End If
        Next Cell
        End With


End Sub

Public Sub OPEN_EXCEL()
Dim fDIAL As FileDialog
Dim strSPECIAL As String
Dim wbOPEN As Workbook


    Set fDIAL = appEXCEL.FileDialog(msoFileDialogFilePicker)
    With fDIAL
        .AllowMultiSelect = False
        .Title = "Please select a file"
        .Filters.Clear
        .Filters.Add "Excel", "*.xls*"
        If .Show = True Then
            strSPECIAL = .SelectedItems(1)
        Else

            MsgBox "User Selected CANCEL." & vbNewLine & "  Please start over!"
            Exit Sub
        End If
    End With

On Error Resume Next
    Set wbOPEN = Workbooks.Open(strSPECIAL)
On error goto 0

End Sub

Public Function LASTROW()
Dim rngLROW As Range
Dim ws As Worksheet
Dim lngROWS As Long

    Set ws = ActiveSheet
    Set rngLROW = ws.Cells

    lngROWS = rngLROW.Find(What:="*", _
        after:=rngLROW.Cells(1), _
        LOOKAT:=xlPart, _
        LookIn:=xlFormulas, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Row
    LASTROW = lngROWS
End Function

Public Function LASTCOL()
Dim rngLCOL As Range
Dim ws As Worksheet
Dim lngCOLS As Long

    Set ws = ActiveSheet
    Set rngLCOL = ws.Cells

    lngCOLS = rngLCOL.Find(What:="*", _
        after:=rngLCOL.Cells(1), _
        LOOKAT:=xlPart, _
        LookIn:=xlFormulas, _
        SearchOrder:=xlByColumns, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Column
    LASTCOL = lngCOLS
End Function

 

[Peter_SSs]

The problem seems to be that it's picking up single characters from the indivividual strings (e.g. keyword " C2C " its picking up " 2 " - which is a separate error code).

Some of the keywords seem to being missed where they appear in amongst other 'text' (e.g. keyword " Table " from an entry that reads " Table: (id: 72) "

I think both of these issues have resulted, at least partly, because your initial "starting code" in post #1 may have been misleading.

1. Your code, & therefore RCBricker's, joined all the keywords with "|" characters, but never used those "|" characters to help identify the start/end of keywords. That means that if a keyword is "pineapple" and the cell being checked contains "apple" then a match is found. Similarly if a keyword is "C2C" and the cell contains "2" then a match is found.

2. In the end, I don't think the above issue will exactly matter as your second point above indicates that the code should be checking if any of the keywords appear in the text of the cell being checked. That is the opposite way round to your post #1 code which is checking if the cell text appears in the keyword list.

The other issue that I wanted to raise is that 500,000 rows is a very large data set. I think code that goes to the worksheet to retrieve a cell value, process that value in code, go back to the sheet if colour needs to be applied and repeat that process half a million times will likely take an extremely long time.

I've not tried to process multiple workbooks, but assumed that we are starting with a single workbook that has a "list" sheet containing the keywords in cell A2 and down from there, and a "DATA" sheet containing the data to be checked. The data can be in any column, but starts in row 2 (assumed headings in row 1). The user is asked to choose the column during the running of the code, so is easily adaptable for different columns.

My sample data had ..
- 20 keywords in "list"
- 500,000 rows (& 10 columns) in "DATA"
- About 40,000 of the 500,000 rows contained a keyword "match" in the column to be checked

My machine processed that data in < 10 seconds using the code below.

Anyway, you might like to give this a try. I'd strongly suggest testing on a copy with a much smaller data set and if it is what you want, gradually work up to larger data.

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, xlNumbers).EntireRow.Resize(, nc - 1).Interior.Color = vbYellow
        .Columns(nc).SpecialCells(xlConstants, xlTextValues).EntireRow.Resize(, nc - 1).Interior.Color = vbRed
        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
      MsgBox "Completed processing column " & Split(rCol.Address(1, 0), "$")(0)   '<- Get rid of this line if you want
    Else
      MsgBox "A single column was not selected, or column input was cancelled. Process aborted."
    End If
  End With
End Sub