Otomatik Sıra Numarası, Kayıt ve Değişiklik Tarihi Oluşturma Kod Yardımı

[Believing]

Sayın Uzman Arkadaşlar,

Ekteki örnek çalışmada ve aşağıdaki kod ile "B" sutunu dolu ise otomatik olarak "A" sütununda sıra numarası, "K" sütununda ilk kayıt tarihi ve "L" sütununda değişiklik tarihi oluşturuyorum.

Private Sub Worksheet_Change(ByVal Target As Range)
        If Target.Row < 1 Or Target.Row > 500 Then Exit Sub
       
        If Intersect(Target, Range("B2:B536")) Is Nothing Then Exit Sub
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
       
        Range("A2:A500").ClearContents
   
        Cells(Target.Row, "L") = Format(Now, "dd.mm.yyyy - hh:mm")
        If Cells(Target.Row, "K") = "" Then
        Cells(Target.Row, "K") = Format(Now, "dd.mm.yyyy - hh:mm")
        End If
        With Range("A2:A500")
        .Formula = "=IF(B2="""","""",MAX(A$2:A500)+1)"
        .Value = .Value
    End With
       
        sa = Target.Row
       
     Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Sizlerden yardımını istediğim ise; "B" sütunundaki herhangi bir hücredeki veriyi sildiğimde, "A", "K", "L" sütunlarının ilgili hücrelerindeki verilerin silinmesini istiyorum. Bu istek için mevcut kodlamayı nasıl revize etmeliyim. Konuya hakim uzman arkadaşların çok değerli yardımlarını rica ediyorum.

Saygılarımla,
Ömer Ali ÜZÜMCÜ

Örnek Çalışma Linki;
http://s2.dosya.tc/server8/oznlrn/ORNEK_BELIEVING_15.rar.html

 

[Korhan Ayhan]

Deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Row < 1 Or Target.Row > 500 Then Exit Sub
    If Intersect(Target, Range("B2:B536")) Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Range("A2:A500").ClearContents

    If Target.Cells.Count = 1 Then
        If Target <> "" Then
            Cells(Target.Row, "L") = Format(Now, "dd.mm.yyyy - hh:mm")
            If Cells(Target.Row, "K") = "" Then
                Cells(Target.Row, "K") = Format(Now, "dd.mm.yyyy - hh:mm")
            End If
        Else
            Cells(Target.Row, "K").ClearContents
            Cells(Target.Row, "L").ClearContents
        End If
    Else
        For Each Hucre In Selection
            If Hucre.Column = 2 Then
                If Hucre.Value = "" Then
                    Cells(Hucre.Row, "K").ClearContents
                    Cells(Hucre.Row, "L").ClearContents
                End If
            End If
        Next
    End If
    
    With Range("A2:A500")
        .Formula = "=IF(B2="""","""",MAX(A$2:A500)+1)"
        .Value = .Value
    End With
        
    sa = Target.Row
        
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

 

[Believing]

Sayın Korhan Ayhan,

Konuya gösterdiğiniz ilgi ve yardım için size çok teşekkür ederim.
ALLAH sizden ve sevdiklerinizden razı olsun.

Saygılarımla,
Ömer Ali ÜZÜMCÜ