Searching multiple substrings in each cell

[schellam]

Hello all,
Accounting has a requirement in the monthly GL file to flag any items in Column A that has the substring either "lunch", "dinner", "drink" embedded in each item in the cell.
With help of one of the postings in this Forum for a similar question, I came up with below VBA code using the InStr function, Array to store the substrings and 2 loops where I like to highlight the row in Green if it has any of the above substrings in each cell.

But the problem is it's highlighting all the blank rows in Sheet2. Appreciate any help on this. Thank you!

Sub Search_list()
Dim CFP_GL As Workbook
Dim cell2 As Range
Dim strConcatList As String
Dim Partial_Text As String
Dim myrange As Range
Dim someArray
Dim arrVal As Variant


Workbooks.Open Filename:="Z:\WIP\CFP GL Jan-Sep 2021-test.xls", UpdateLinks:=False
Set CFP_GL = Application.Workbooks("CFP GL Jan-Sep 2021-test.xls")
Set myrange = CFP_GL.Sheets("Sheet2").Range("A:A")


someArray = Array("dinner", "lunch", "drink")

myrange.Interior.Pattern = xlNone 'This clears all existing colour

For Each cell2 In myrange 'Going through each row in Column A in Sheet 2 of the Workbook
    For Each arrVal In someArray
        If InStr(arrVal, cell2.Value) <> 0 Then 'InStr should returns 0 if the string isn't found
            cell2.EntireRow.Interior.ColorIndex = 4 'Highlights the row in green
        End If
    Next arrVal
Next cell2

End Sub

 

[Akuini]

I think this part:

If InStr(arrVal, cell2.Value) <> 0 Then

should be:

If InStr(cell2.Value, arrVal) <> 0 Then

or if you want it to be case insensitive, then:

If InStr(1, cell2.Value, arrVal, vbTextCompare) <> 0 Then

 

[schellam]

I think this part:

If InStr(arrVal, cell2.Value) <> 0 Then

should be:

If InStr(cell2.Value, arrVal) <> 0 Then

or if you want it to be case insensitive, then:

If InStr(1, cell2.Value, arrVal, vbTextCompare) <> 0 Then

Thanks so much Akuni, that did it!! Can't believe it was just a simple switch. One quick question, I like to modify below to store in a Column in Excel sheet so users can maintain it. Would you happen to have the VBA that store Column list in Array? Thanks again!

someArray = Array("dinner", "lunch", "drink")

 

[Akuini]

to store in a Column in Excel sheet so users can maintain it.

Say, it's in Sheet1, start at A1 downward:

With Sheets("Sheet1")
    someArray = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Value
End With

 

[Akuini]

Also, to make it faster:
1. you can turn Application.ScreenUpdating off & on
2. exit the loop the first time it found a match

like this:

Sub Search_list()
Dim CFP_GL As Workbook
Dim cell2 As Range
Dim strConcatList As String
Dim Partial_Text As String
Dim myrange As Range
Dim someArray
Dim arrVal As Variant


Workbooks.Open Filename:="Z:\WIP\CFP GL Jan-Sep 2021-test.xls", UpdateLinks:=False
Set CFP_GL = Application.Workbooks("CFP GL Jan-Sep 2021-test.xls")
Set myrange = CFP_GL.Sheets("Sheet2").Range("A:A")

Application.ScreenUpdating = False
With Sheets("Sheet1")
    someArray = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Value
End With

myrange.Interior.Pattern = xlNone 'This clears all existing colour

For Each cell2 In myrange 'Going through each row in Column A in Sheet 2 of the Workbook
    For Each arrVal In someArray
        If InStr(cell2.Value, arrVal) <> 0 Then 'InStr should returns 0 if the string isn't found
            cell2.EntireRow.Interior.ColorIndex = 4 'Highlights the row in green
            Exit For 'exit this loop the first time it found a match
        End If
    Next arrVal
Next cell2
Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

Welcome to the MrExcel board!

Also to make it faster, you can

• Test for all substrings at once for each row
• Only test the the rows where there could be substring values instead of all 1,048,576 rows in the sheet
• Test the values in memory, not accessing the worksheet repeatedly
• Apply the colour all at once rather than access the sheet each individual time a relevant row is found

Assuming the substring list is in Sheet1 starting at A2 of the workbook containing the code and has no blank cells in the list then a suggested alternative approach addressing the above points is..

Sub Search_list_v2()
  Dim CFP_GL As Workbook
  Dim RX As Object
  Dim a As Variant, b As Variant
  Dim i As Long, nc As Long
  Dim bFound As Boolean
 
  Workbooks.Open Filename:="Z:\WIP\CFP GL Jan-Sep 2021-test.xls", UpdateLinks:=False
  Set CFP_GL = Application.Workbooks("CFP GL Jan-Sep 2021-test.xls")
 
  Set RX = CreateObject("VBScript.RegExp")
'  RX.IgnoreCase = True
  With ThisWorkbook.Sheets("Sheet1")
      RX.Pattern = Join(Application.Transpose(.Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Value), "|")
  End With
  Application.ScreenUpdating = False
  With CFP_GL.Sheets("Sheet2")
    nc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    a = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value
    ReDim b(1 To UBound(a), 1 To 1)
    .Columns("A").Resize(, nc).Interior.Pattern = xlNone  'This clears all existing colour
    For i = 1 To UBound(a)
      If RX.Test(a(i, 1)) Then
        b(i, 1) = 1
        bFound = True
      End If
    Next i
    If bFound Then
      With .Columns(nc).Resize(UBound(b))
        .Value = b
        Intersect(.SpecialCells(xlConstants).EntireRow, .Parent.Columns("A").Resize(, nc - 1)).Interior.ColorIndex = 4 'Highlights the row in green
        .ClearContents
      End With
    End If
  End With
  Application.ScreenUpdating = True
End Sub

BTW, my code does not highlight entire rows - only as far as the last column in the sheet that contains data.

Two further points to consider

1. The first has already been mentioned - whether you want the search to be case-sensitive or not. Currently my code is case-sensitive, so it would not highlight "Drink" if the substring list is "drink".
   If you want to make it non case-sensitive then uncomment the 'IgnoreCase' line in the code
   
   
2. Just checking that you want to search for strings, not words. If "drink" is in the list, do you want to highlight rows with values like these?
   "The water is not drinkable", or
   "Met with Tom Drinkwater"

 

[schellam]

Say, it's in Sheet1, start at A1 downward:

With Sheets("Sheet1")
    someArray = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Value
End With

Thank you!!!

 

[Akuini]

@schellam
You should try @Peter_SSs code because it's faster.
Or at least in my code, change this part (because this part really slows down the code):

Set myrange = CFP_GL.Sheets("Sheet2").Range("A:A")

to this:

With CFP_GL.Sheets("Sheet2")
    myrange = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
End With