Блог

Как выделить желтым цветом ячейку, в которой есть определенное слово?
У меня есть данные в колонках B и F со словом «Нет игры».
Как я могу сделать это в vba в excel?

Спасибо

Хотя на этот вопрос уже был дан ответ, я бы рискнул, показав, насколько легко это сделать с помощью условного форматирования (скриншоты немного уменьшены).:

Результат выглядит так:

Удачи

Выделите совпадения ( For Each...Next )

• Скопируйте полный код в стандартный модуль, например Module1 .
• Отрегулируйте (поиграйте) значения в разделе константы.

 Option Explicit

Sub HighlightColumns()
' Needs the 'RefColumn' and 'RefCombinedRange' functions.
    Const ProcTitle As String = "Highlight Columns"

    Const wsName As String = "Sheet1"
    Const FirstCellsList As String = "B2,H2"
    Const hCriteria As String = "No Game"
    Const hColor As Long = vbYellow
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    
    ' Write the list of the first cells' addresses to an array ('FirstCells').
    Dim FirstCells() As String: FirstCells = Split(FirstCellsList, ",")
    
    Dim scrg As Range ' Source Column Range
    Dim sfCell As Range ' Source First Cell
    Dim sCell As Range ' Source Cell
    Dim hrg As Range ' Highlight Range
    Dim n As Long ' Columns Counter
    
    ' Combine all matching cells into the Highlight Range.
    For n = 0 To UBound(FirstCells)
        Set sfCell = ws.Range(FirstCells(n))
        Set scrg = RefColumn(sfCell)
        If Not scrg Is Nothing Then ' found data in column range
            For Each sCell In scrg.Cells
                If StrComp(CStr(sCell.Value), hCriteria, vbTextCompare) = 0 Then
                    Set hrg = RefCombinedRange(hrg, sCell)
                'Else ' not a match
                End If
            Next sCell
            Set scrg = Nothing
        'Else ' no data in current column range
        End If
    Next n
    
    ' Highlight and inform.
    If Not hrg Is Nothing Then ' Highlight Criteria found
        hrg.Interior.Color = hColor
        MsgBox "Highlighted cells equal to '" amp; hCriteria amp; "'.", _
            vbInformation, ProcTitle
    Else ' no Highlight Criteria found
        MsgBox "No occurrences of '" amp; hCriteria amp; "' found.", _
            vbExclamation, ProcTitle
    End If
    
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the one-column range from the first cell
'               of a range ('FirstCell') to the bottom-most non-empty cell
'               of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
    ByVal FirstCell As Range) _
As Range
    If FirstCell Is Nothing Then Exit Function
    
    With FirstCell.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row   1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row   1)
    End With

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to a range combined from two ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCombinedRange( _
    ByVal CombinedRange As Range, _
    ByVal AddRange As Range) _
As Range
    If CombinedRange Is Nothing Then
        Set RefCombinedRange = AddRange
    Else
        Set RefCombinedRange = Union(CombinedRange, AddRange)
    End If
End Function