Fill in date in specific column & Row based on cell value

user_18988492 0
Viewed 62

I have received a request to fill in date based on specific status chosen (cell value) in a column representing that status. For example if I choose a Status "Event_1" in column A from a drop down list, macro should find a column with the same name (Event_1) and fill in date in that column for the Row where the status was changed.

enter image description here

I only got as far as filling adjacent cell with a date when said cell is changed. I know I should probably adjust offset to a column number representing my status, however I'm not sure how to achieve this.

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim ColNum As Integer
    
    With Target
        If .Count > 1 Then Exit Sub
        If Not Intersect(Range("A:A"), .Cells) Is Nothing Then
            Application.EnableEvents = False
            If IsEmpty(.Value) Then
                .Offset(0, 1).ClearContents
            Else
                With .Offset(0, 1)
                    .NumberFormat = "dd mmm yyyy"
                    .Value = Now
                End With
            End If
            Application.EnableEvents = True
        End If
    End With
End Sub
offset vba excel
2 Answers

What about this?

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ColNum As Integer

With Target
    If .Count > 1 Then Exit Sub
    If Not Intersect(Range("A:A"), .Cells) Is Nothing Then
        Application.EnableEvents = False
        If IsEmpty(.Value) Then
            '.Offset(0, 1).ClearContents
            'Why???
        Else
            ColNum = Application.WorksheetFunction.Match(Target.Value, Range("1:1"), 0)
            With .Offset(0, ColNum - 1)
                .NumberFormat = "dd mmm yyyy"
                .Value = Now
            End With
        End If
        Application.EnableEvents = True
    End If
End With

End Sub

The only part I don't get is this one:

If IsEmpty(.Value) Then
            .Offset(0, 1).ClearContents

Why? You should specify what you want to do when there is no option selected.

user_91998280

A Worksheet Change: One Timestamp Per Row

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ClearError
    
    Const FirstColCellAddress As String = "B1"
    Const FirstRowCellAddress As String = "A2"
    Const TimeFormat As String = "dd/mm/yyyy hh:mm:ss"
    
    Dim scrg As Range
    With Range(FirstRowCellAddress)
        Set scrg = .Resize(.Worksheet.Rows.Count - .Row + 1)
    End With
    
    Dim irg As Range: Set irg = Intersect(scrg, Target)
    If irg Is Nothing Then Exit Sub
    
    Dim srrg As Range
    Dim sCell As Range
    
    With Range(FirstColCellAddress)
        Set sCell = .Resize(, .Worksheet.Columns.Count - .Column + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        Set srrg = .Resize(, sCell.Column - .Column + 1)
    End With
    
    Dim sIndex As Variant
    Dim sString As String
    
    Dim drrg As Range
    Dim dCell As Range
    
    Dim rgClear As Range
    Dim rgTime As Range
    
    For Each sCell In irg.Cells
        
        Set drrg = srrg.Rows(sCell.Row - srrg.Row + 1)
        If rgClear Is Nothing Then
            Set rgClear = drrg
        Else
            Set rgClear = Union(rgClear, drrg)
        End If
        
        sString = CStr(sCell.Value)
        sIndex = Application.Match(sString, srrg, 0)
        
        If IsNumeric(sIndex) Then
            Set dCell = drrg.Cells(sIndex)
            If rgTime Is Nothing Then
                Set rgTime = dCell
            Else
                Set rgTime = Union(rgTime, dCell)
            End If
        End If
    
    Next sCell
    
    Application.EnableEvents = False
    
    If Not rgClear Is Nothing Then rgClear.Clear
    
    If Not rgTime Is Nothing Then
        Dim TimeStamp As Date: TimeStamp = Now
        With rgTime
            .NumberFormat = TimeFormat
            .Value = TimeStamp
        End With
    End If
    
SafeExit:
    If Not Application.EnableEvents Then Application.EnableEvents = True
    
    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub
user_98140690
Related