Find All Cells That Contain A Certain Value

**Rasm** · 04-25-2011, 03:53 AM

I have a column with either the Value "True" or "False" - I use the code below to highlight the cells with the value "True" by changing the backcolor. It all works great - except when I get to having found 10K plus values it really slows down. When I hit 20K it is very slow. The RED code is where it slows down - If I rem out that part it keeps up the speed.
Any suggestions. I modified code posted by VoG on MrExcel - Thanks VoG.

I guess the lookat:=xlWhole - should be changed to xlpart - but not sure how to do that - I assume you can set the Columns/Rows to limit the search to.

My second question is - if say the values in the cells were

blue shirt, red socks, blue pants, black shoes, blue shoes and so on

how can I find all the cells containing the word blue.

Code:

Public Sub FindValueX(ByRef WhatToFind As String, ByRef WhatBook As String, ByRef WhatSheet As String, ByRef FirstColToSearch As Long, ByRef LastColToSearch As Long, ByRef HighLightFound As Boolean, ByVal FoundRange As Range)
    If Trim(WhatToFind) = "" Then
        strMsg = "You have not specified a 'value' to search for."
        intMsgType = vbOKOnly
        intResponse = MsgBox(strMsg, intMsgType, "Searching for Value")
        Exit Sub
    End If
    If Trim(WhatBook) = "" Then WhatBook = ActiveWorkbook.Name
    If Trim(WhatSheet) = "" Then WhatSheet = ActiveSheet.Name
    Dim tempcell As Range, Found As Range
    Dim FirstRow As Long, FirstCol As Long
    With Workbooks(WhatBook).Worksheets(WhatSheet).UsedRange
        ColLast = .Rows(.Rows.Count).Row
        LastRow = .Rows(.Rows.Count).Row
    End With
    Set Found = Workbooks(WhatBook).Worksheets(WhatSheet).Range("A1")
    Set tempcell = Cells.Find(What:=WhatToFind, After:=Found, LookIn:=xlValues, lookat:=xlWhole)
    If tempcell Is Nothing Then
        MsgBox prompt:="The value '" & WhatToFind & ", cannot be found"
        Exit Sub
    Else
        Set Found = tempcell
        Set FoundRange = Found
    End If
    FirstRow = Found.Row
    FirstCol = Found.Column
    Along = 1
    AAlong = 0
    Do
        Set tempcell = Cells.FindNext(After:=Found)
        If tempcell.Row = FirstRow And tempcell.Column = FirstCol Then Exit Do
        Set Found = tempcell
        If tempcell.Column >= FirstColToSearch And tempcell.Column <= LastColToSearch Then
            Set FoundRange = Application.Union(FoundRange, Found)            
            If Along > 200 Then
                Application.StatusBar = "Finding '" & WhatToFind & "'   (" & AAlong & ")"
                Along = 1
            End If
            Along = Along + 1
            AAlong = AAlong + 1
        End If
    Loop
    If HighLightFound Then
            FoundRange.Interior.Color = &HC0FFFF    'Light Yellow
        Else
            FoundRange.Interior.ColorIndex = xlNone
    End If
    Application.StatusBar = "Completed"
End Sub

**Rasm** · 04-25-2011, 05:13 AM

ahhh the xlpart is the search string - so that finds Blue - so now I only have the speed issue left

**Admin** · 04-25-2011, 10:28 AM

Hi Rasm,

Try this code. It took only 3 secs to scan 280,000 cells and color the background.

Code:

Sub kTest()
    
    Dim strCellAddr(1 To 5000)  As String
    Dim ka, rngToSearch         As Range
    Dim i   As Long, j As Long, n As Long
    Dim txt As String
    
    Set rngToSearch = ActiveSheet.UsedRange
    
    Const SearchWord    As String = "red"
    
    Debug.Print Now
    ka = rngToSearch
    
    For i = 1 To UBound(ka, 1)
        For j = 1 To UBound(ka, 2)
            If InStr(LCase$(ka(i, j)), LCase$(SearchWord)) Then
                txt = txt & "," & Cells(i, j).Address(0, 0)
                If Len(txt) > 245 Then
                    n = n + 1
                    strCellAddr(n) = Mid$(txt, 2)
                    txt = vbNullString
                End If
            End If
        Next
    Next
    If Len(txt) > 1 Then
        n = n + 1
        strCellAddr(n) = Mid$(txt, 2)
        txt = vbNullString
    End If
                
    With rngToSearch
        For i = 1 To n
            .Range(CStr(strCellAddr(i))).Interior.Color = 10092543
        Next
    End With
    
    Debug.Print Now
    
End Sub