"if and" statement with criteria from two columns

user_18245364 0
Viewed 58

I have this code that inputs today's date into a cell when another cell is marked "Complete". It basically says if a cell in column D is changed to "Complete", put today's date into column P.

I need to add another criteria into the if statement. I want the if statement to say "if column D is marked complete AND column "N" marked "No", put today's date in column P.

Thank you in advance for your help!

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
If Not Intersect(Columns("D"), Target) Is Nothing Then
    Application.EnableEvents = False
    For Each c In Intersect(Columns("D"), Target).Cells
        If (c.Value) = "Complete" Then
            Cells(c.Row, "P").Value = Date
        Else
            If IsEmpty(c) Then Cells(c.Row, "P").Value = ""
        End If
    Next c
    Application.EnableEvents = True
End If
End Sub
vba excel
1 Answers

Worksheet Change: Monitoring Multiple Columns

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ClearError
    
    Dim sCols As Variant: sCols = VBA.Array("D", "N")
    Dim sCrit As Variant: sCrit = VBA.Array("Complete", "No")
    Const dCol As String = "P"
    Const fRow As Long = 2
    
    Dim cUpper As Long: cUpper = UBound(sCols)
    Dim Offsets() As Long: ReDim Offsets(0 To cUpper)
    
    Dim rg As Range
    Dim srg As Range
    Dim c As Long
    
    With Columns(sCols(0))
        Set rg = .Resize(.Rows.Count - fRow + 1).Offset(fRow - 1)
        For c = 0 To cUpper
            If c = cUpper Then
                Offsets(cUpper) = Columns(dCol).Column - .Column
            Else
                Offsets(c) = Columns(sCols(c + 1)).Column - .Column
                Set srg = Union(rg, rg.Offset(, Offsets(c)))
            End If
        Next c
    End With
    
    Dim sirg As Range: Set sirg = Intersect(srg, Target)
    If sirg Is Nothing Then Exit Sub
    Set sirg = Intersect(sirg.EntireRow, srg.Areas(1).Columns(1))
    
    Dim siCell As Range
    Dim siString As String
    Dim deurg As Range
    Dim dvurg As Range
    Dim dCell As Range
    Dim FoundMismatch As Boolean
    
    For Each siCell In sirg.Cells
        siString = CStr(siCell.Value)
        Set dCell = siCell.Offset(, Offsets(cUpper))
        If Len(siString) = 0 Then
            If deurg Is Nothing Then ' combining empty cells into 'deurg'
                Set deurg = dCell
            Else
                Set deurg = Union(deurg, dCell)
            End If
        Else
            ' Check the source cells' values against the criteria.
            If StrComp(siString, sCrit(0), vbTextCompare) = 0 Then ' first
                For c = 1 To cUpper ' all other (1 at the moment)
                    If StrComp(CStr(siCell.Offset(, Offsets(c - 1)).Value), _
                            sCrit(c), vbTextCompare) <> 0 Then
                        FoundMismatch = True
                        Exit For
                    End If
                Next c
                If FoundMismatch Then
                    FoundMismatch = False
                Else ' combining date cells into 'dvurg'
                    If dvurg Is Nothing Then
                        Set dvurg = dCell
                    Else
                        Set dvurg = Union(dvurg, dCell)
                    End If
                End If
            End If
        End If
    Next siCell
    
    Application.EnableEvents = False ' before writing

    ' Only now writing Empties and Dates. 
    If Not deurg Is Nothing Then deurg.Value = Empty
    If Not dvurg Is Nothing Then dvurg.Value = Date
    
SafeExit:
    On Error Resume Next
        If Not Application.EnableEvents Then Application.EnableEvents = True
    On Error GoTo 0
    
    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub
user_98140690
Related