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!
 

wigi

Well-known Member
Joined
Jul 10, 2006
Messages
7,944
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.
 

LondonExcel

New Member
Joined
Aug 10, 2011
Messages
12
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
 

wigi

Well-known Member
Joined
Jul 10, 2006
Messages
7,944
Sorry, the line above should read:

Code:
If Not FoundCells Is Nothing Then
Insert the Not please.
 

LondonExcel

New Member
Joined
Aug 10, 2011
Messages
12
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!
 

LondonExcel

New Member
Joined
Aug 10, 2011
Messages
12
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!
 

wigi

Well-known Member
Joined
Jul 10, 2006
Messages
7,944
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:

LondonExcel

New Member
Joined
Aug 10, 2011
Messages
12
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!
 

Forum statistics

Threads
1,081,846
Messages
5,361,668
Members
400,644
Latest member
ndroger1

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top