Need to highlight array if condition is met. But How?


I have a cell with data to filter with specific text (pre-filtered). just want to highlight specific cells with the cell value that meet the array of special cells.

Sub EmailDataPrep()

    Dim r As Range 
    Dim lastrow As Long 
    Dim MyArray() As Variant
    MyArray = Range("F3:F200")
    currow = Sheets("Current_Emails").Range("F3")
    lastrow = Cells(Rows.Count, "F3").End(xlUp).row
    For Each r In Range("F" & currow & "F" & lastrow)
        If r.Value = MyArray Then
            r.Interior.Color = "Green"
        End If
    Next r

End Sub


Highlight Matching Cells

  • Adjust the values in the constants section.
  • It is assumed that there are two worksheets in the workbook containing this code.
  • The values of the Source Column Range will be written to an array. A loop through the cells of the Destination (Column) Range, will attempt to match each cell value against the array. If a match is found, the reference to the current cell will be combined in the Combined Range. Finally, all (matching) cells of the Combined Range will be highlighted.
Option Explicit

Sub EmailDataPrep()

    ' Source
    Const sName As String = "Sheet1" '***
    Const sFirst As String = "F3"
    ' Destination
    Const dName As String = "Current_Emails"
    Const dFirst As String = "F3"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook
    ' Define Source Range and write its values to Data Array.
    Dim srg As Range
    With wb.Worksheets(sName).Range(sFirst)
        Dim sCell As Range
        Set sCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If sCell Is Nothing Then Exit Sub
        Set srg = .Resize(sCell.Row - .Row + 1)
    End With
    Dim Data As Variant: Data = srg.Value
    ' Define Destination Range.
    Dim drg As Range
    With wb.Worksheets(dName).Range(dFirst)
        Dim dCell As Range
        Set dCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If dCell Is Nothing Then Exit Sub
        Set drg = .Resize(dCell.Row - .Row + 1)
    End With
    ' Loop through cells of Destination Range and attempt to find
    ' a match in Data Array. If found, combine its reference to the matching cell
    ' in the Combined Range.
    Dim crg As Range
    For Each dCell In drg.Cells
        If IsNumeric(Application.Match(dCell.Value, Data, 0)) Then
            If crg Is Nothing Then
                Set crg = dCell
                Set crg = Union(crg, dCell)
            End If
        End If
    Next dCell
    ' Highlight matching cells (cells of the Combined Range) in one go.
    If Not crg Is Nothing Then
        crg.Interior.Color = vbGreen
    End If
End Sub

Answered By – VBasic2008

Answer Checked By – Pedro (AngularFixing Volunteer)

Leave a Reply

Your email address will not be published.