Select specific cell from a range and offset it

Question

I need help with the following code:

Sub highlightspecificvalue()

    'highlight all cells containing a specified value`enter code here`
    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
    fnd = InputBox("i want to highlight cells containing...", "highlight")    
    'end if cancel button is clicked or no text is entered
     If fnd = vbNullString Then Exit Sub

     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    

     If IsEmpty(cells(1,2).Offset(1, 0)) = False Then
        cells(1,2).Interior.Color = RGB(255, 255, 0)
     ElseIf IsEmpty(cells(1,2).Offset(1, 0)) = True Then
        cells(1,2).Interior.Color = RGB(255, 255, 255)
     End If

    'highlight found cells yellow
     rng.Interior.Color = RGB(255, 255, 0)

    'message
     MsgBox rng.cells.Count & "cell(s) were found containing: " & fnd & " 
     found at " & rng.Address        
     Exit Sub

    'error
nothingfound:
     MsgBox "no cells containing: " & fnd & " were found in this worksheet"

End Sub

This is what the table looks like in excel:

 plug   |  CH       |   CHA     |    CHB    |     CHA     |       CHB
-------------------------------------------------------------------------
   1    | emptycell |     9     | emptycell |      5      |       4
-------------------------------------------------------------------------
   2    | emptycell |     8     | emptycell |      4      |       5
-------------------------------------------------------------------------
   3    | emptycell |     7     | emptycell |      3      |       6
-------------------------------------------------------------------------
   4    | emptycell |     6     | emptycell |      2      |       7
-------------------------------------------------------------------------

What I would like the code to do is the following:

when searching for a term using the inputbox, only highlight the cells that have data underneath them. For example, if I wanted to see how many channels there were, I would type "ch" into the inputbox and expect to see only certain cells in the first row highlighted because there is data underneath those specific cells: CHA cell in cell(3,1) should be highlighted because there is data underneath it and so should CHA in cell (5,1), and CHB in cell (6,1).

Unfortunately, the code is highlighting all the words in the first row that contain "CH", which includes cells (2,1) and (4,1), even though there is no data in those columns.

I have tried different loops and have not been successful. I think that my main issue is coming from the second if loop near the end of the code.

I have gotten help from reading various online forums and website tutorials since I am new to VBA and learning the language, however, I am stuck on this issue.

Any help and suggestions that I receive on this would be greatly appreciated.

Tim Williams Tim Williams · Accepted Answer · 2017-06-30T17:00:12

It's more convenient to push the "find all matches" code into its own function so you can concentrate on the core logic:

Sub highlightspecificvalue()

    'highlight all cells containing a specified value
    Dim fnd As String
    Dim rng As Range, c As Range
    Dim rngFound As Range, i As Long

    fnd = InputBox("i want to highlight cells containing...", "highlight")
    If fnd = vbNullString Then Exit Sub

    Set rng = ActiveSheet.UsedRange
    rng.Interior.ColorIndex = xlNone 'clear any existing color

    Set rngFound = FindAll(rng, fnd) 'get any matches
    If Not rngFound Is Nothing Then
        For Each c In rngFound.Cells
            'check for any content for 4 cells down
            '   expand/contract this to suit....
            If Application.CountA(c.Offset(1, 0).Resize(4, 1)) > 0 Then
                c.Interior.Color = vbYellow
                i = i + 1
            End If
        Next c
        MsgBox rngFound.Cells.Count & " cell(s) were found containing: '" & _
                fnd & "' found in " & rngFound.Address & vbLf & _
                i & " were highlighted"
    Else
        MsgBox "No cells containing: " & fnd & " were found in this worksheet"
    End If

End Sub






'find all matching cells in a given range
Function FindAll(rngLookIn As Range, LookFor) As Range

    Dim rv As Range, c As Range, FirstAddress As String
    With rngLookIn
        Set c = .Find(LookFor, lookat:=xlPart)
        If Not c Is Nothing Then
            FirstAddress = c.Address
            Set rv = c
            Do
                Set c = .FindNext(c)
                If Not c Is Nothing Then Set rv = Application.Union(rv, c)
            Loop While Not c Is Nothing And c.Address <> FirstAddress
        End If
    End With
    Set FindAll = rv
End Function

Select specific cell from a range and offset it

1 Answers