Highlight Cells Containing Search Terms Across All Sheets

[lneidorf]

Hi there.

I've been working with an excellent piece of code posted (reproduced below) on thespreadsheetguru.com, here:
https://www.thespreadsheetguru.com/the-code-vault/2014/4/21/find-all-instances-with-vba

This code searches a sheet for text and highlights the cells containing matches.

I'm trying to adapt it in the following ways:

1. How can I get this to go through ALL sheets in the active workbook (and not just the active sheet)?
2. Rather than hard-coding a single search criteria, how can I pass the contents of a range of cells (the terms contained in cells B2:B11 on a sheet entitled "Search Terms")?

Any help would be most appreciated.

Thanks!

Sub HighlightFindValues()

'PURPOSE: Highlight all cells containing a specified values
'SOURCE: www.TheSpreadsheetGuru.com

Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range

'What value do you want to find (must be in string form)?
  fnd = "Kentucky"

Set myRange = ActiveSheet.UsedRange
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(what:=fnd, after:=LastCell)

'Test to see if anything was found
  If Not FoundCell Is Nothing Then
    FirstFound = FoundCell.Address
  Else
    GoTo NothingFound
  End If

Set rng = FoundCell

'Loop until cycled through all unique finds
  Do Until FoundCell Is Nothing
    'Find next cell with fnd value
      Set FoundCell = myRange.FindNext(after:=FoundCell)
    
    'Add found cell to rng range variable
      Set rng = Union(rng, FoundCell)
    
    'Test to see if cycled through to first found cell
      If FoundCell.Address = FirstFound Then Exit Do
      
  Loop

'Highlight Found cells yellow
  rng.Interior.Color = RGB(255, 255, 0)
  
Exit Sub

'Error Handler
NothingFound:
  MsgBox "No values were found in this worksheet"

End Sub

 

[tonyyy]

lneidorf,

You might consider the following...

Sub HighlightFindValues()

'PURPOSE: Highlight all cells containing a specified values
'SOURCE: www.TheSpreadsheetGuru.com

Dim ws As Worksheet
Dim r As Range
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range

For Each ws In ThisWorkbook.Worksheets
    For Each r In Sheets("Search Terms").Range("B2:B11")
        'What value do you want to find (must be in string form)?
          If r.Value <> "" Then
            fnd = r.Value
          Else
            Exit For
          End If
        
        Set myRange = ws.UsedRange
        Set LastCell = myRange.Cells(myRange.Cells.Count)
        Set FoundCell = myRange.Find(what:=fnd, after:=LastCell)
        
        'Test to see if anything was found
          If Not FoundCell Is Nothing Then
            FirstFound = FoundCell.Address
          Else
            GoTo NothingFound
          End If
        
        Set rng = FoundCell
        
        'Loop until cycled through all unique finds
          Do Until FoundCell Is Nothing
            'Find next cell with fnd value
              Set FoundCell = myRange.FindNext(after:=FoundCell)
            
            'Add found cell to rng range variable
              Set rng = Union(rng, FoundCell)
            
            'Test to see if cycled through to first found cell
              If FoundCell.Address = FirstFound Then Exit Do
          Loop
        
        'Highlight Found cells yellow
          rng.Interior.Color = RGB(255, 255, 0)
    Next r
Next ws
MsgBox "Done!"
Exit Sub
'Error Handler
NothingFound:
  MsgBox "No values were found in this worksheet " & ws.Name
End Sub

Cheers,

tonyyy

 

[lneidorf]

Thanks Tonyyy.

When I run this, I get a "Subscript out of range" error (Error 9). I should note that I do have a sheet named "Search Terms" and the specified range is populated with values.

Any thoughts?

Thank you!

 

[tonyyy]

You don't state directly, but I assume the line that's highlighted with the error is...

For Each r In Sheets("Search Terms").Range("B2:B11")

Might there be an extra space(es) in the tab name "Search Terms" - ie, "Search Terms " or "Search Terms"?

 

[lneidorf]

Thanks Tonyyy.

Always a good suggestion, but I'm afraid that's not it. I even tried renaming the tab without spaces and copying the name directly into the code.

Alternatively, I'm thinking that it might be easier to hard-code the terms right into the code for the time being. So instead of referring to multiple values in a range of cells, just listing them out in the code, much as the original code does:

'What value do you want to find (must be in string form)?
fnd = "Kentucky" OR "Virginia" OR "Louisiana"

I've no idea how to adapt the code to use that kind of logic (OR). I'd be grateful if you could point me in the right direction.

Thanks!

 

[tonyyy]

The only way I can reproduce the "Subscript out of range" error is to mismatch the tab name with the sheet name in the code, otherwise the code runs fine in my Windows 7 / Excel 2010 environment. A Protected sheet or workbook produces a different error, if any, and if B2:B11 is the result of a formula or PivotTable it still executes without error. Maybe you're on a Mac or using an older version of Excel?

That said, the following will hard code multiple terms into the macro...

Sub HighlightFindValues_1026965r2()
Dim ws As Worksheet
Dim arr As Variant, i As Long
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range

arr = Array("Louisiana", "Kentucky", "Virginia") 'Edit/Add terms as needed
For Each ws In ThisWorkbook.Worksheets
    For i = LBound(arr) To UBound(arr)
        fnd = arr(i)
        Set myRange = ws.UsedRange
        Set LastCell = myRange.Cells(myRange.Cells.Count)
        Set FoundCell = myRange.Find(what:=fnd, after:=LastCell)
        
        If Not FoundCell Is Nothing Then
            FirstFound = FoundCell.Address
        Else
            GoTo Nexxt
        End If
        
        Set rng = FoundCell
        Do Until FoundCell Is Nothing
            Set FoundCell = myRange.FindNext(after:=FoundCell)
            Set rng = Union(rng, FoundCell)
            If FoundCell.Address = FirstFound Then Exit Do
        Loop
        rng.Interior.Color = RGB(255, 255, 0)
Nexxt:
    Next i
Next ws
Beep
MsgBox "Done!"
End Sub

 

[lneidorf]

Tonyyy,

Spectacular. That indeed works.

My issue finally occurred to me. This is a reminder of the importance of explaining the entire context of the code, which I did not do here.

I've got another piece of code, in a separate macro, that prompts the user to navigate to a folder, and then runs whatever code desired across all files in the folder, saving them and closing them when done.

So here, I've got a folder full of Excel files. The user is promoted to navigate to the folder. Then, the code I have been posting here executes. That's in its own macro.

The issue was the conflict between the reference

 For Each ws In ThisWorkbook.Worksheets

and the fact that I was activating another file via the master macro.

I resolved that by instead using

 For Each ws In ActiveWorkbook.Worksheets

So my final question is this:
How do I make reference to the code in the original notebook, where my macro lives, and then have the code I've posted here execute against the active workbooks, which are being opened one by one and then saved? The idea is to pull the terms in a static range in the original workbook and pass them through the code, which will open a series of other files, look for each term across all sheets, highlight them, and then save the files, moving on to the next file in the folder.

Thanks so much for you time. Hugely appreciated.

 

[Rick Rothstein]

The only way I can reproduce the "Subscript out of range" error is to mismatch the tab name with the sheet name in the code, otherwise the code runs fine in my Windows 7 / Excel 2010 environment. A Protected sheet or workbook produces a different error, if any, and if B2:B11 is the result of a formula or PivotTable it still executes without error. Maybe you're on a Mac or using an older version of Excel?

That said, the following will hard code multiple terms into the macro...

Sub HighlightFindValues_1026965r2()
Dim ws As Worksheet
Dim arr As Variant, i As Long
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range

arr = Array("Louisiana", "Kentucky", "Virginia") 'Edit/Add terms as needed
For Each ws In ThisWorkbook.Worksheets
    For i = LBound(arr) To UBound(arr)
        fnd = arr(i)
        Set myRange = ws.UsedRange
        Set LastCell = myRange.Cells(myRange.Cells.Count)
        Set FoundCell = myRange.Find(what:=fnd, after:=LastCell)
        
        If Not FoundCell Is Nothing Then
            FirstFound = FoundCell.Address
        Else
            GoTo Nexxt
        End If
        
        Set rng = FoundCell
        Do Until FoundCell Is Nothing
            Set FoundCell = myRange.FindNext(after:=FoundCell)
            Set rng = Union(rng, FoundCell)
            If FoundCell.Address = FirstFound Then Exit Do
        Loop
        rng.Interior.Color = RGB(255, 255, 0)
Nexxt:
    Next i
Next ws
Beep
MsgBox "Done!"
End Sub

Here is another way to do it which might be a tad, and I do mean tad, faster (it doesn't iterate each matching cell individually on the sheet)...

[table="width: 500"]
[tr]
	[td]Sub HighlightFindValues_1026965r2()
  Dim WS As Worksheet, V As Variant, Arr As Variant
  Arr = Array("Louisiana", "Kentucky", "Virginia") 'Edit/Add terms as needed
  Application.ReplaceFormat.Clear
  Application.ReplaceFormat.Interior.Color = vbRed
  For Each WS In ThisWorkbook.Worksheets
    With WS.UsedRange
      For Each V In Arr
        .Replace V, "", xlWhole, , False, , False, True
      Next
    End With
  Next
  Application.ReplaceFormat.Clear
End Sub[/td]
[/tr]
[/table]

 

[Rick Rothstein]

Here is another way to do it which might be a tad, and I do mean tad, faster (it doesn't iterate each matching cell individually on the sheet)...

[table="width: 500"]
[tr]
	[td]Sub HighlightFindValues_1026965r2()
  Dim WS As Worksheet, V As Variant, Arr As Variant
  Arr = Array("Louisiana", "Kentucky", "Virginia") 'Edit/Add terms as needed
  Application.ReplaceFormat.Clear
  Application.ReplaceFormat.Interior.Color = [B][COLOR="#FF0000"]vbRed[/COLOR][/B]
  For Each WS In ThisWorkbook.Worksheets
    With WS.UsedRange
      For Each V In Arr
        .Replace V, "", xlWhole, , False, , False, True
      Next
    End With
  Next
  Application.ReplaceFormat.Clear
End Sub[/td]
[/tr]
[/table]

I meant to change the highlighted color to vbYellow to match the color tonyyy used (I used vbRed so I could see that I hit the same cells as tonyyy did when testing my code).

 

[lapta301]

Hi Rick

I found this which pretty much does what I need to a problem that has landed on my desk.

However, I need to find a complete word that might also have one or two other words in the cell.

So if I'm searching for London I would want it to locate the word in a cell that contains City of London

And pushing my luck is it possible at the end to have a message box that shows how many have been found across all sheets.

Grateful thanks