VBA automatically show date when detect particular result from excel formula

user_19150697 0
Viewed 42

I am trying with VBA to get the current date on column H (Date) but It does not work well. here is the problem

  1. In column F (Result) if I manually type Preferred or Non-preferred. after press Enter today date will be automatically put on column H (Date)
  2. But when I paste formula instead (which will consider data from column A-E to show result on its cell). even if the result give Preferred or Non-preferred the date will not automatically show up like VBA cannot detect that. unless I press double-click and enter on each result cell then it will show up. can someone figure it out please

this is vba that i use

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim St As String
St = "Preferred|Non-Preferred"
If Not Intersect(Columns("F"), Target) Is Nothing Then
    Application.EnableEvents = False
    For Each c In Intersect(Columns("F"), Target).Cells
        If InStr(1, St, c.Value, vbTextCompare) >= 1 Then
            Cells(c.Row, "H").Value = Date
        Else
            If IsEmpty(c) Then Cells(c.Row, "H").Value = ""
        End If
    Next c
    Application.EnableEvents = True
End If
End Sub

this is the example for more understanding enter image description here

excel-formula vba excel
1 Answers

A Worksheet Change: Using Precedents

  • In column F is a formula that calculates dependent on the values of columns A:E (precedents). The code will trigger when the values in columns A:E are manually changed, possibly modifying the value in column H (see OP's description (requirements)).
  • The Select Case statement could be reduced to two cases: either it begins with Criteria (1) or it doesn't (Else).
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ClearError
       
    Const sFirstCellAddress As String = "F2"
    Const dCol As String = "H"
    Const Criteria As String = "Preferred"
    
    Dim srg As Range
    
    With Me.Range(sFirstCellAddress)
        Set srg = .Resize(Me.Rows.Count - .Row + 1)
    End With
    
    Dim irg As Range: Set irg = Intersect(srg.Precedents, Target)
    
    If irg Is Nothing Then Exit Sub
    
    Set srg = Intersect(irg.EntireRow, Columns(srg.Column))
    
    Dim drg As Range: Set drg = srg.EntireRow.Columns(dCol)
    
    Application.EnableEvents = False
    
    Dim dCell As Range
    Dim n As Long
    
    For Each dCell In drg.Cells
        n = n + 1
        Select Case InStr(1, CStr(srg.Cells(n).Value), Criteria, vbTextCompare)
        Case 0
             dCell.Value = Empty ' criteria not found
        Case 1
             dCell.Value = Date ' begins with criteria
        Case Else
             dCell.Value = Empty ' contains criteria
        End Select
    Next dCell

SafeExit:
    If Not Application.EnableEvents Then Application.EnableEvents = True
    
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub
user_98140690
Related