Macro/VBA: highlight rows based on 2 conditions

user_9969942 0
Viewed 238

Objective is to highlight rows that meet two different conditions:

  1. If column A is equal to the previous workday (taking into consideration of holidays mentioned in the Reference sheet)
  2. If column B is not equal to "AA"

I have the following code, but am unable to get appropriate rows highlighted (no rows get highlighted due to condition #1 not being met):

Sub code()

    Dim lrow As Long
    lrow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To lrow
    If Cells(i, "A").Value = "=WORKDAY(today(),-1,Reference!$A$2:$A$12)" And Cells(i, "B").Value <> "AA"  Then Cells(i, 1).EntireRow.Interior.ColorIndex = 6
    Next i
  
End Sub
vba excel
2 Answers

You could try this:

Option Explicit

Sub code()

    Dim i As Long, lrow As Long
    Dim objRangeHolidays As Range
    
    Set objRangeHolidays = Worksheets("Reference").Range("$A$2", "$A$12")
    
    lrow = Cells(rows.Count, "A").End(xlUp).row
    
    For i = 2 To lrow
      If CDate(Cells(i, "A").Value) = CDate(Application.WorksheetFunction.WorkDay(Date, -1, objRangeHolidays)) And Cells(i, "B").Value <> "AA" Then
        Cells(i, 1).EntireRow.Interior.ColorIndex = 6
      End If
    Next i
  
    Set objRangeHolidays = Nothing
  
End Sub

Your original code does not work as "=WORKDAY(today(),-1,Reference!$A$2:$A$12)" is a literal string on VBA, not a function call.

We use CDate() function to make our cell values comparable with WorksheetFunction.Workday() function.

WorksheetFunction.Today() is the same as Date() in VBA.

objRangeHolidays holds holidays defined in Reference sheet.

This is my test result:

enter image description here

user_9530970

Highlight Entire Rows

  • Adjust the values in the constants section.
Option Explicit

Sub highlightPreviousWorkday()
    
    ' Source
    Const sName As String = "Sheet1"
    Const sFirst As String = "A2"
    Const sCritCol As String = "B"
    Const sCriteria As String = "AA"
    Const sColorIndex As Long = 6
    ' Holiday
    Const hName As String = "Reference"
    Const hFirst As String = "A2"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    wb.Activate ' `Evaluate` will fail if not active.
    
    ' Source
    Dim srg As Range
    With wb.Worksheets(sName).Range(sFirst)
        Dim slCell As Range
        Set slCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If slCell Is Nothing Then Exit Sub
        Set srg = .Resize(slCell.Row - .Row + 1)
    End With
    
    ' Holiday
    Dim Holiday As String
    With wb.Worksheets(hName).Range(hFirst)
        Dim hlCell As Range
        Set hlCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If Not hlCell Is Nothing Then
            Holiday = ",'" & hName & "'!" _
                & .Resize(hlCell.Row - .Row + 1).Address
        End If
    End With
    
    ' Evaluation
    Dim evDate As Variant
    evDate = Evaluate("WORKDAY(TODAY(),-1" & Holiday & ")")
    
    ' Combine
    Dim drg As Range
    If VarType(evDate) = vbDouble Then
        Dim sCell As Range
        Dim sValue As Variant
        Dim sString As String
        For Each sCell In srg.Cells
            sValue = sCell.Value
            If VarType(sValue) = vbDate Then
                If CDbl(sValue) = evDate Then
                    sString = CStr(sCell.EntireRow.Columns(sCritCol).Value)
                    If sString <> sCriteria Then
                        Set drg = getCombinedRange(drg, sCell)
                    End If
                End If
            End If
        Next sCell
    End If
  
    ' Color
    Application.ScreenUpdating = False
    srg.EntireRow.Interior.ColorIndex = xlNone
    If Not drg Is Nothing Then
        drg.EntireRow.Interior.ColorIndex = sColorIndex
    End If
    Application.ScreenUpdating = True
     
End Sub

Function getCombinedRange( _
    ByVal BuiltRange As Range, _
    ByVal AddRange As Range) _
As Range
        If BuiltRange Is Nothing Then
            Set getCombinedRange = AddRange
        Else
            Set getCombinedRange = Union(BuiltRange, AddRange)
        End If
End Function
user_98140690
Related