Hücre değiştiğinde tarih yazsın.

[abnur]

Merhaba,

Burada d sütununda bir veri girdiğinde sağ tarafına tarihi yazıyor.
Benim istediğim, D sütununda veri ilk girildiğinde sağ tarafa yazması ve D sütunundaki veri tekrar değiştirildiğinde sağ tarafa tekrar tarih yazmaması.
Yardımlarınızı rica ederim.

Private Sub Worksheet_Change(ByVal Target As Range)
'Update AbNuR 202253
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("D"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Now
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub

 

[Muzaffer Ali]

Merhaba.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Rng As Range
    If Not Intersect(Range("D:D"), Target) Is Nothing Then
        Application.EnableEvents = False
        For Each Rng In Target
            If Not VBA.IsEmpty(Rng.Value) Then
                If VBA.IsEmpty(Rng.Offset(0, 1)) Then Rng.Offset(0, 1).Value = Now
            Else
                Rng.Offset(0, 1).ClearContents
            End If
        Next
        Application.EnableEvents = True
    End If
End Sub

 

[abnur]

Çok teşekkür ederim.

Merhaba.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Rng As Range
    If Not Intersect(Range("D:D"), Target) Is Nothing Then
        Application.EnableEvents = False
        For Each Rng In Target
            If Not VBA.IsEmpty(Rng.Value) Then
                If VBA.IsEmpty(Rng.Offset(0, 1)) Then Rng.Offset(0, 1).Value = Now
            Else
                Rng.Offset(0, 1).ClearContents
            End If
        Next
        Application.EnableEvents = True
    End If
End Sub

 

[Muzaffer Ali]

Rica ederim. Kolay gelsin.