Question

我需要以下代码的帮助：

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

这就是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
-------------------------------------------------------------------------

我希望代码的作用如下：

使用输入框搜索术语时，只突出显示其下方数据的单元格。例如，如果我想看看有多少频道，我会输入＆＃34; ch＆＃34;进入输入框并期望只看到第一行中的某些单元格突出显示，因为这些特定单元格下面有数据：单元格（3,1）中的CHA单元格应该突出显示，因为它下面有数据，因此单元格中应该有CHA（5），1）和细胞中的CHB（6,1）。

不幸的是，代码突出显示第一行中包含＆＃34; CH＆＃34;的所有单词，其中包括单元格（2,1）和（4,1），即使这些单词中没有数据列。

我尝试过不同的循环并且没有成功。我认为我的主要问题来自于代码末尾附近的第二个if循环。

我从阅读各种在线论坛和网站教程中得到了帮助，因为我是VBA的新手并且学习了这门语言，但是，我坚持这个问题。

我将非常感谢您收到的任何帮助和建议。

Answer 1

将“查找所有匹配”代码推送到自己的函数中更方便，这样您就可以专注于核心逻辑：

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

从某个范围中选择特定单元格并将其偏移

1 个答案: