'"if and" statement with criteria from two columns
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
Solution 1:[1]
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
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
| Solution | Source |
|---|---|
| Solution 1 |
