Search and highlight cells loop

LondonExcel

New Member
Joined
Aug 10, 2011
Messages
12
First time posting! I have found part of what I need but am having trouble completing the macro...
I need a macro in excel that will loop through a large spreadsheet and highlight cells based on the contents of each cell in a column.

For example, I need the macro to take the contents of A1 (ex:"Apple") and then search the whole spreadsheet highlighting any cell that contains the word "apple". Then it needs to go to the second row and search the whole sheet for the contents of B1 (Ex: "Ball"), highlighting any cell containing the word 'Ball'.

Can this be done by adding onto this code?

Code:
Sub find_highlight()  

criteria =    
'Not sure how to make this loop through the cells in a column  

Cells.Find(What:=(Criteria), After:=ActiveCell, LookIn:=xlFormulas,
 _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
 _ MatchCase:=False).Activate  

With Selection.Interior[INDENT].ColorIndex = 6
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic 
[/INDENT]End With  
End Sub
<code> </code>

Many thanks!
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Hello

Welcome to MrExcel.

Try:

Code:
Option Explicit
Option Compare Text

Sub find_highlight()

    Dim FoundCells As Range
    Dim rngCell As Range

    For Each rngCell In Range("A1:B1")

        Set FoundCells = FindAll(SearchRange:=ActiveSheet.UsedRange.Columns(1).Offset(1), _
                                 FindWhat:=rngCell.Text, _
                                 LookIn:=xlValues, _
                                 LookAt:=xlWhole, _
                                 SearchOrder:=xlByColumns, _
                                 MatchCase:=False, _
                                 BeginsWith:=vbNullString, _
                                 EndsWith:=vbNullString, _
                                 BeginEndCompare:=vbTextCompare)
        If FoundCells Is Nothing Then
            FoundCells.Interior.ColorIndex = Int(Rnd * 55) + 1
        End If
    
    Next

End Sub

Paste this into a regular module in VBA.

You also need the function below, taken from Chip Pearson (http://www.cpearson.com/excel/FindAll.aspx)

Code:
Function FindAll(SearchRange As Range, _
                 FindWhat As Variant, _
                 Optional LookIn As XlFindLookIn = xlValues, _
                 Optional LookAt As XlLookAt = xlWhole, _
                 Optional SearchOrder As XlSearchOrder = xlByRows, _
                 Optional MatchCase As Boolean = False, _
                 Optional BeginsWith As String = vbNullString, _
                 Optional EndsWith As String = vbNullString, _
                 Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FindAll
' This searches the range specified by SearchRange and returns a Range object
' that contains all the cells in which FindWhat was found. The search parameters to
' this function have the same meaning and effect as they do with the
' Range.Find method. If the value was not found, the function return Nothing. If
' BeginsWith is not an empty string, only those cells that begin with BeginWith
' are included in the result. If EndsWith is not an empty string, only those cells
' that end with EndsWith are included in the result. Note that if a cell contains
' a single word that matches either BeginsWith or EndsWith, it is included in the
' result.  If BeginsWith or EndsWith is not an empty string, the LookAt parameter
' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Dim FoundCell As Range
    Dim FirstFound As Range
    Dim LastCell As Range
    Dim ResultRange As Range
    Dim XLookAt As XlLookAt
    Dim Include As Boolean
    Dim CompMode As VbCompareMethod
    Dim Area As Range
    Dim MaxRow As Long
    Dim MaxCol As Long
    Dim BeginB As Boolean
    Dim EndB As Boolean


    CompMode = BeginEndCompare
    If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
        XLookAt = xlPart
    Else
        XLookAt = LookAt
    End If

    ' this loop in Areas is to find the last cell
    ' of all the areas. That is, the cell whose row
    ' and column are greater than or equal to any cell
    ' in any Area.
    For Each Area In SearchRange.Areas
        With Area
            If .Cells(.Cells.Count).Row > MaxRow Then
                MaxRow = .Cells(.Cells.Count).Row
            End If
            If .Cells(.Cells.Count).Column > MaxCol Then
                MaxCol = .Cells(.Cells.Count).Column
            End If
        End With
    Next Area
    Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)


    'On Error Resume Next
    On Error GoTo 0
    Set FoundCell = SearchRange.Find(what:=FindWhat, _
                                     after:=LastCell, _
                                     LookIn:=LookIn, _
                                     LookAt:=XLookAt, _
                                     SearchOrder:=SearchOrder, _
                                     MatchCase:=MatchCase)

    If Not FoundCell Is Nothing Then
        Set FirstFound = FoundCell
        'Set ResultRange = FoundCell
        'Set FoundCell = SearchRange.FindNext(after:=FoundCell)
        Do Until False    ' Loop forever. We'll "Exit Do" when necessary.
            Include = False
            If BeginsWith = vbNullString And EndsWith = vbNullString Then
                Include = True
            Else
                If BeginsWith <> vbNullString Then
                    If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
                        Include = True
                    End If
                End If
                If EndsWith <> vbNullString Then
                    If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
                        Include = True
                    End If
                End If
            End If
            If Include = True Then
                If ResultRange Is Nothing Then
                    Set ResultRange = FoundCell
                Else
                    Set ResultRange = Application.Union(ResultRange, FoundCell)
                End If
            End If
            Set FoundCell = SearchRange.FindNext(after:=FoundCell)
            If (FoundCell Is Nothing) Then
                Exit Do
            End If
            If (FoundCell.Address = FirstFound.Address) Then
                Exit Do
            End If

        Loop
    End If

    Set FindAll = ResultRange

End Function

Function FindAllOnWorksheets(InWorkbook As Workbook, _
                             InWorksheets As Variant, _
                             SearchAddress As String, _
                             FindWhat As Variant, _
                             Optional LookIn As XlFindLookIn = xlValues, _
                             Optional LookAt As XlLookAt = xlWhole, _
                             Optional SearchOrder As XlSearchOrder = xlByRows, _
                             Optional MatchCase As Boolean = False, _
                             Optional BeginsWith As String = vbNullString, _
                             Optional EndsWith As String = vbNullString, _
                             Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Variant
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FindAllOnWorksheets
' This function searches a range on one or more worksheets, in the range specified by
' SearchAddress.
'
' InWorkbook specifies the workbook in which to search. If this is Nothing, the active
'   workbook is used.
'
' InWorksheets specifies what worksheets to search. InWorksheets can be any of the
' following:
'   - Empty: This will search all worksheets of the workbook.
'   - String: The name of the worksheet to search.
'   - String: The names of the worksheets to search, separated by a ':' character.
'   - Array: A one dimensional array whose elements are any of the following:
'           - Object: A worksheet object to search. This must be in the same workbook
'               as InWorkbook.
'           - String: The name of the worksheet to search.
'           - Number: The index number of the worksheet to search.
' If any one of the specificed worksheets is not found in InWorkbook, no search is
' performed. The search takes place only after everything has been validated.
'
' The other parameters have the same meaning and effect on the search as they do
' in the Range.Find method.
'
' Most of the code in this procedure deals with the InWorksheets parameter to give
' the absolute maximum flexibility in specifying which sheet to search.
'
' This function requires the FindAll procedure, also in this module or avaialable
' at www.cpearson.com/Excel/FindAll.aspx.
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Dim WSArray() As String
    Dim WS As Worksheet
    Dim WB As Workbook
    Dim ResultRange() As Range
    Dim WSNdx As Long
    Dim R As Range
    Dim SearchRange As Range
    Dim FoundRange As Range
    Dim WSS As Variant
    Dim N As Long


    '''''''''''''''''''''''''''''''''''''''''''
    ' Determine what Workbook to search.
    '''''''''''''''''''''''''''''''''''''''''''
    If InWorkbook Is Nothing Then
        Set WB = ActiveWorkbook
    Else
        Set WB = InWorkbook
    End If

    '''''''''''''''''''''''''''''''''''''''''''
    ' Determine what sheets to search
    '''''''''''''''''''''''''''''''''''''''''''
    If IsEmpty(InWorksheets) = True Then
        ''''''''''''''''''''''''''''''''''''''''''
        ' Empty. Search all sheets.
        ''''''''''''''''''''''''''''''''''''''''''
        With WB.Worksheets
            ReDim WSArray(1 To .Count)
            For WSNdx = 1 To .Count
                WSArray(WSNdx) = .Item(WSNdx).Name
            Next WSNdx
        End With

    Else
        '''''''''''''''''''''''''''''''''''''''
        ' If Object, ensure it is a Worksheet
        ' object.
        ''''''''''''''''''''''''''''''''''''''
        If IsObject(InWorksheets) = True Then
            If TypeOf InWorksheets Is Excel.Worksheet Then
                ''''''''''''''''''''''''''''''''''''''''''
                ' Ensure Worksheet is in the WB workbook.
                ''''''''''''''''''''''''''''''''''''''''''
                If StrComp(InWorksheets.Parent.Name, WB.Name, vbTextCompare) <> 0 Then
                    ''''''''''''''''''''''''''''''
                    ' Sheet is not in WB. Get out.
                    ''''''''''''''''''''''''''''''
                    Exit Function
                Else
                    ''''''''''''''''''''''''''''''
                    ' Same workbook. Set the array
                    ' to the worksheet name.
                    ''''''''''''''''''''''''''''''
                    ReDim WSArray(1 To 1)
                    WSArray(1) = InWorksheets.Name
                End If
            Else
                '''''''''''''''''''''''''''''''''''''
                ' Object is not a Worksheet. Get out.
                '''''''''''''''''''''''''''''''''''''
            End If
        Else
            '''''''''''''''''''''''''''''''''''''''''''
            ' Not empty, not an object. Test for array.
            '''''''''''''''''''''''''''''''''''''''''''
            If IsArray(InWorksheets) = True Then
                '''''''''''''''''''''''''''''''''''''''
                ' It is an array. Test if each element
                ' is an object. If it is a worksheet
                ' object, get its name. Any other object
                ' type, get out. Not an object, assume
                ' it is the name.
                ''''''''''''''''''''''''''''''''''''''''
                ReDim WSArray(LBound(InWorksheets) To UBound(InWorksheets))
                For WSNdx = LBound(InWorksheets) To UBound(InWorksheets)
                    If IsObject(InWorksheets(WSNdx)) = True Then
                        If TypeOf InWorksheets(WSNdx) Is Excel.Worksheet Then
                            ''''''''''''''''''''''''''''''''''''''
                            ' It is a worksheet object, get name.
                            ''''''''''''''''''''''''''''''''''''''
                            WSArray(WSNdx) = InWorksheets(WSNdx).Name
                        Else
                            ''''''''''''''''''''''''''''''''
                            ' Other type of object, get out.
                            ''''''''''''''''''''''''''''''''
                            Exit Function
                        End If
                    Else
                        '''''''''''''''''''''''''''''''''''''''''''
                        ' Not an object. If it is an integer or
                        ' long, assume it is the worksheet index
                        ' in workbook WB.
                        '''''''''''''''''''''''''''''''''''''''''''
                        Select Case UCase(TypeName(InWorksheets(WSNdx)))
                        Case "LONG", "INTEGER"
                            Err.Clear
                            '''''''''''''''''''''''''''''''''''
                            ' Ensure integer if valid index.
                            '''''''''''''''''''''''''''''''''''
                            Set WS = WB.Worksheets(InWorksheets(WSNdx))
                            If Err.Number <> 0 Then
                                '''''''''''''''''''''''''''''''
                                ' Invalid index.
                                '''''''''''''''''''''''''''''''
                                Exit Function
                            End If
                            ''''''''''''''''''''''''''''''''''''
                            ' Valid index. Get name.
                            ''''''''''''''''''''''''''''''''''''
                            WSArray(WSNdx) = WB.Worksheets(InWorksheets(WSNdx)).Name
                        Case "STRING"
                            Err.Clear
                            '''''''''''''''''''''''''''''''''''''
                            ' Ensure valid name.
                            '''''''''''''''''''''''''''''''''''''
                            Set WS = WB.Worksheets(InWorksheets(WSNdx))
                            If Err.Number <> 0 Then
                                '''''''''''''''''''''''''''''''''
                                ' Invalid name, get out.
                                '''''''''''''''''''''''''''''''''
                                Exit Function
                            End If
                            WSArray(WSNdx) = InWorksheets(WSNdx)
                        End Select
                    End If
                    'WSArray(WSNdx) = InWorksheets(WSNdx)
                Next WSNdx
            Else
                ''''''''''''''''''''''''''''''''''''''''''''
                ' InWorksheets is neither an object nor an
                ' array. It is either the name or index of
                ' the worksheet.
                ''''''''''''''''''''''''''''''''''''''''''''
                Select Case UCase(TypeName(InWorksheets))
                Case "INTEGER", "LONG"
                    '''''''''''''''''''''''''''''''''''''''
                    ' It is a number. Ensure sheet exists.
                    '''''''''''''''''''''''''''''''''''''''
                    Err.Clear
                    Set WS = WB.Worksheets(InWorksheets)
                    If Err.Number <> 0 Then
                        '''''''''''''''''''''''''''''''
                        ' Invalid index, get out.
                        '''''''''''''''''''''''''''''''
                        Exit Function
                    Else
                        WSArray = Array(WB.Worksheets(InWorksheets).Name)
                    End If
                Case "STRING"
                    '''''''''''''''''''''''''''''''''''''''''''''''''''
                    ' See if the string contains a ':' character. If
                    ' so, the InWorksheets contains a string of multiple
                    ' worksheets.
                    '''''''''''''''''''''''''''''''''''''''''''''''''''
                    If InStr(1, InWorksheets, ":", vbBinaryCompare) > 0 Then
                        ''''''''''''''''''''''''''''''''''''''''''
                        ' ":" character found. split apart sheet
                        ' names.
                        ''''''''''''''''''''''''''''''''''''''''''
                        WSS = Split(InWorksheets, ":")
                        Err.Clear
                        N = LBound(WSS)
                        If Err.Number <> 0 Then
                            '''''''''''''''''''''''''''''
                            ' Unallocated array. Get out.
                            '''''''''''''''''''''''''''''
                            Exit Function
                        End If
                        If LBound(WSS) > UBound(WSS) Then
                            '''''''''''''''''''''''''''''
                            ' Unallocated array. Get out.
                            '''''''''''''''''''''''''''''
                            Exit Function
                        End If


                        ReDim WSArray(LBound(WSS) To UBound(WSS))
                        For N = LBound(WSS) To UBound(WSS)
                            Err.Clear
                            Set WS = WB.Worksheets(WSS(N))
                            If Err.Number <> 0 Then
                                Exit Function
                            End If
                            WSArray(N) = WSS(N)
                        Next N
                    Else
                        Err.Clear
                        Set WS = WB.Worksheets(InWorksheets)
                        If Err.Number <> 0 Then
                            '''''''''''''''''''''''''''''''''
                            ' Invalid name, get out.
                            '''''''''''''''''''''''''''''''''
                            Exit Function
                        Else
                            WSArray = Array(InWorksheets)
                        End If
                    End If
                End Select
            End If
        End If
    End If
    '''''''''''''''''''''''''''''''''''''''''''
    ' Ensure SearchAddress is valid
    '''''''''''''''''''''''''''''''''''''''''''
    On Error Resume Next
    For WSNdx = LBound(WSArray) To UBound(WSArray)
        Err.Clear
        Set WS = WB.Worksheets(WSArray(WSNdx))
        ''''''''''''''''''''''''''''''''''''''''
        ' Worksheet does not exist
        ''''''''''''''''''''''''''''''''''''''''
        If Err.Number <> 0 Then
            Exit Function
        End If
        Err.Clear
        Set R = WB.Worksheets(WSArray(WSNdx)).Range(SearchAddress)
        If Err.Number <> 0 Then
            ''''''''''''''''''''''''''''''''''''
            ' Invalid Range. Get out.
            ''''''''''''''''''''''''''''''''''''
            Exit Function
        End If
    Next WSNdx

    ''''''''''''''''''''''''''''''''''''''''
    ' SearchAddress is valid for all sheets.
    ' Call FindAll to search the range on
    ' each sheet.
    ''''''''''''''''''''''''''''''''''''''''
    ReDim ResultRange(LBound(WSArray) To UBound(WSArray))
    For WSNdx = LBound(WSArray) To UBound(WSArray)
        Set WS = WB.Worksheets(WSArray(WSNdx))
        Set SearchRange = WS.Range(SearchAddress)
        Set FoundRange = FindAll(SearchRange:=SearchRange, _
                                 FindWhat:=FindWhat, _
                                 LookIn:=LookIn, LookAt:=LookAt, _
                                 SearchOrder:=SearchOrder, _
                                 MatchCase:=MatchCase, _
                                 BeginsWith:=BeginsWith, _
                                 EndsWith:=EndsWith)

        If FoundRange Is Nothing Then
            Set ResultRange(WSNdx) = Nothing
        Else
            Set ResultRange(WSNdx) = FoundRange
        End If
    Next WSNdx

    FindAllOnWorksheets = ResultRange

End Function

No doubt the solution could be simpler, but now you have a very generic solution which can handle a lot more situations.
 
Upvote 0
Thanks for that! I see what the function does and it makes sense but when I run the macro I get the error "Object variable or With block variable not set" at this line:

Code:
FoundCells.Interior.ColorIndex = Int(Rnd * 55) + 1
 
Upvote 0
Sorry, the line above should read:

Code:
If Not FoundCells Is Nothing Then

Insert the Not please.
 
Upvote 0
Okay now the error has stopped but the function is not finding anything. Maybe I need to change the range? I'm trying to highlight in columns B through F any cell which contains any of the the words found in column A (3100 rows). Do I need to change the code to make this happen?

Much appreciated!
 
Upvote 0
Apologies, I thought I would be able to adapt the function to my needs based on the example I provided but it seems my limited VBA skills aren't up to the challenge!

However, I am testing the function on a spreadsheet set up exactly like my example: "Apple" in A1 and "Ball" in B1, with the words "Apple" and "Ball" placed in random cells in the sheet, and this is not working.

I don't mean to waste anyone's time or be difficult, I'm just trying to understand this so I can apply it in future!
 
Upvote 0
Rich (BB code):
Option Explicit
Option Compare Text

Sub find_highlight()

    Dim FoundCells As Range
    Dim rngCell As Range

    For Each rngCell In Range("A1", Range("A" & Rows.Count).End(xlUp))

       If Len(rngCell.Text) Then

        Set FoundCells = FindAll(SearchRange:=ActiveSheet.UsedRange, _
                                 FindWhat:=rngCell.Text, _
                                 LookIn:=xlValues, _
                                 LookAt:=xlWhole, _
                                 SearchOrder:=xlByColumns, _
                                 MatchCase:=False, _
                                 BeginsWith:=vbNullString, _
                                 EndsWith:=vbNullString, _
                                 BeginEndCompare:=vbTextCompare)
        If Not FoundCells Is Nothing Then
            FoundCells.Interior.ColorIndex = Int(Rnd * 55) + 1
        End If

    End If

    Next

End Sub
 
Last edited:
Upvote 0
Works perfectly when change the If FoundCells line to be "If Not FoundCells"... Thank you so much for your patience and help! I can't tell you how much I appreciate it!
 
Upvote 0

Forum statistics

Threads
1,224,600
Messages
6,179,836
Members
452,947
Latest member
Gerry_F

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top