• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Kayıt ve Değişikliği Oluşturmak

B

Believing

Altın Üye
Katılım
19 Mayıs 2013
Mesajlar
703
Excel Vers. ve Dili
Office Pro 2019 TR 32 Bit
Windows Pro 10 TR 64 Bit
Sayın Uzman Arkadaşlar,

Bir excel çalışmasında C,D ve E sütünlarına veri girilmesi durumunda M sütununda ilk kayıt tarihi(İlk girilen tarih asla değişmeyecek), N sütununda ise değişiklik tarihi (verilerin değiştirilmesi durumunda on son yapılan değişiklik tarihi) oluşturulması isteniyor. Konu ile ilgili istekler örnek dosyada daha detaylı alatılmıştır. Bu çalışmayla ilgili kod yazma konusunda yetersiz olduğumu belirterek, siz uzman arkadaşlardan değerli yardımlarınızı rica ediyorum.

Saygılarımla.
 

Ekli dosyalar

. . .

Çalışma sayfasının kod bölümüne yapıştırın

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [C:E]) Is Nothing Then Exit Sub
On Error GoTo hata

Cells(Target.Row, "N") = Format(Now, "dd.mm.yyyy - hh:mm")
If Cells(Target.Row, "M") = "" Then
Cells(Target.Row, "M") = Format(Now, "dd.mm.yyyy - hh:mm")
End If

sa = Target.Row
If WorksheetFunction.CountA(Range("C" & sa & ":E" & sa)) = 0 Then
Cells(Target.Row, "M") = ""
Cells(Target.Row, "N") = ""
End If
hata:

End Sub

. . .
 
Bende kod hazırlamıştım. Alternatif olarak deneyebilirsiniz.

Kod: 
Dim Eski_Veri

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Alan As Range, Veri As Range
    Set Alan = Range("C:E")
    If Intersect(Target, Alan) Is Nothing Then Exit Sub
    If Target.Row < 3 Then Exit Sub
    On Error GoTo Son
    Application.EnableEvents = False
    If Target.Cells.Count = 1 Then
        If Target <> "" Then
            If Eski_Veri = "" Then
                Cells(Target.Row, "M") = Format(Now, "dd.mm.yyyy - hh:mm:ss")
                Eski_Veri = Target
            End If
            If Target <> Eski_Veri Then
                Cells(Target.Row, "N") = Format(Now, "dd.mm.yyyy - hh:mm:ss")
                Eski_Veri = Target
            End If
        Else
            Cells(Target.Row, "M") = ""
            Cells(Target.Row, "N") = ""
        End If
    Else
        For Each Veri In Target
            If Not Intersect(Alan, Veri) Is Nothing Then
                If WorksheetFunction.CountA(Range("C" & Veri.Row & ":E" & Veri.Row)) = 0 Then
                    Cells(Veri.Row, "M") = ""
                    Cells(Veri.Row, "N") = ""
                Else
                    Cells(Veri.Row, "N") = Format(Now, "dd.mm.yyyy - hh:mm:ss")
                End If
            End If
        Next
    End If
    Eski_Veri = ActiveCell
Son: Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Eski_Veri = Target
End Sub
 
Sayın Hüseyin ÇOBAN ve Korhan AYHAN,

Vermiş olduğunuz kodlar ekteki dosyada sorunsuz çalışmaktadır. Ancak, ekteki dosya aşağıdaki kod ile çalışmakta olup, verdiğiniz konları bu kodlar ile entegre ederek çalıştıramadım.

Saygılarımla.
Kod: 
DefStr S
    DefInt A
    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim tip As VbMsgBoxStyle, yanit As VbMsgBoxResult
    a = Target.Row
    If Target.Row > 1 And Target.Column = 3 And Target.Value <> "" Then
    adet1 = WorksheetFunction.CountIf(Range("c2:c" & Range("c65536").End(3).Row), Target.Value)
    If adet1 > 1 Then
        tip = vbQuestion + vbYesNo
        soru1 = "Mükkerrer kayıt bulundu"
        soru2 = "İşleme devam edilsin mi ? "
        yanit = MsgBox(soru1 & vbNewLine & soru2, tip, "MÜKERRER KAYIT")
        If yanit = vbNo Then
            Target.Value = Empty
            Exit Sub
        End If
    End If
    End If
    If Target.Row > 1 And (Target.Column = 4 Or Target.Column = 5) And Target.Value <> "" Then
    adet1 = WorksheetFunction.CountIf(Range("c2:c" & Range("c65536").End(3).Row), Range("c" & a).Value)
    adet2 = WorksheetFunction.CountIf(Range("d2:d" & Range("d65536").End(3).Row), Range("d" & a).Value)
    adet3 = WorksheetFunction.CountIf(Range("e2:e" & Range("c65536").End(3).Row), Range("e" & a).Value)
    If adet1 > 1 And adet2 > 1 And adet3 > 1 Then
        MsgBox "Mükerrer kayıt bulundu. İşleme devam edilemiyor. " & vbNewLine & _
        "Yazılan bilgiler silinecektir.", vbExclamation, "MÜKERRER KAYIT"
        Range("c" & a).Value = Empty
        Range("d" & a).Value = Empty
        Range("e" & a).Value = Empty
        End If
    End If
    soru1 = vbNullString: soru2 = vbNullString
    a = Empty: adet1 = Empty: adet2 = Empty: adet3 = Empty
    yanit = Empty: tip = Empty
    End Sub
Bu kod sayın Tarkan VURAL tarfından hazırlanmıştır.
 
Believing' Alıntı:
Vermiş olduğunuz kodlar ekteki dosyada sorunsuz çalışmaktadır. Ancak, ekteki dosya aşağıdaki kod ile çalışmakta olup, verdiğiniz kodları bu kodlar ile entegre ederek çalıştıramadım.

Saygılarımla.
Genişletmek için tıkla ...

Merhaba kodları aşağıdakiler ile değiştirip denermisin.
Kod: 
DefStr S
    DefInt A
Dim Eski_Veri

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, [C:E]) Is Nothing Then Cells(Target.Row, "M") = Format(Now, "dd.mm.yyyy - hh:mm")
  
    Dim Alan As Range, Veri As Range
    Set Alan = Range("C:E")
    If Intersect(Target, Alan) Is Nothing Then Exit Sub
    If Target.Row < 3 Then Exit Sub
    On Error GoTo Son
    Application.EnableEvents = False
    If Target.Cells.Count = 1 Then
        If Target <> "" Then
            If Eski_Veri = "" Then
                Cells(Target.Row, "M") = Format(Now, "dd.mm.yyyy - hh:mm")
                Eski_Veri = Target
            End If
            If Target <> Eski_Veri Then
                Cells(Target.Row, "N") = Format(Now, "dd.mm.yyyy - hh:mm")
                Eski_Veri = Target
            End If
        Else
            Cells(Target.Row, "M") = ""
            Cells(Target.Row, "N") = ""
        End If
    Else
        For Each Veri In Target
            If Not Intersect(Alan, Veri) Is Nothing Then
                If WorksheetFunction.CountA(Range("C" & Veri.Row & ":E" & Veri.Row)) = 0 Then
                    Cells(Veri.Row, "M") = ""
                    Cells(Veri.Row, "N") = ""
                Else
                    Cells(Veri.Row, "N") = Format(Now, "dd.mm.yyyy - hh:mm:ss")
                End If
            End If
        Next
    End If
    Eski_Veri = ActiveCell
  Dim tip As VbMsgBoxStyle, yanit As VbMsgBoxResult
    A = Target.Row
    If Target.Row > 1 And Target.Column = 3 And Target.Value <> "" Then
    adet1 = WorksheetFunction.CountIf(Range("c2:c" & Range("c65536").End(3).Row), Target.Value)
    If adet1 > 1 Then
        tip = vbQuestion + vbYesNo
        soru1 = "Mükkerrer kayıt bulundu"
        soru2 = "İşleme devam edilsin mi ? "
        yanit = MsgBox(soru1 & vbNewLine & soru2, tip, "MÜKERRER KAYIT")
        If yanit = vbNo Then
            Target.Value = Empty
            Exit Sub
        End If
    End If
    End If
    
    If Target.Row > 1 And (Target.Column = 4 Or Target.Column = 5) And Target.Value <> "" Then
    adet1 = WorksheetFunction.CountIf(Range("c2:c" & Range("c65536").End(3).Row), Range("c" & A).Value)
    adet2 = WorksheetFunction.CountIf(Range("d2:d" & Range("d65536").End(3).Row), Range("d" & A).Value)
    adet3 = WorksheetFunction.CountIf(Range("e2:e" & Range("E65536").End(3).Row), Range("e" & A).Value)
    If adet1 > 1 And adet2 > 1 And adet3 > 1 Then
        MsgBox "Mükerrer kayıt bulundu. İşleme devam edilemiyor. " & vbNewLine & _
        "Yazılan bilgiler silinecektir.", vbExclamation, "MÜKERRER KAYIT"
        Range("c" & A).Value = Empty
        Range("d" & A).Value = Empty
        Range("e" & A).Value = Empty
        End If
    End If
    soru1 = vbNullString: soru2 = vbNullString
    A = Empty: adet1 = Empty: adet2 = Empty: adet3 = Empty
    yanit = Empty: tip = Empty
Son: Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    'Eski_Veri = Target
End Sub
 
Believing' Alıntı:
Sayın Hüseyin ÇOBAN ve Korhan AYHAN,
Vermiş olduğunuz kodlar ekteki dosyada sorunsuz çalışmaktadır. Ancak, ekteki dosya aşağıdaki kod ile çalışmakta olup, verdiğiniz konları bu kodlar ile entegre ederek çalıştıramadım.
Saygılarımla.
Genişletmek için tıkla ...

. . .

Bu tür işlemlerde. Çalışmata olan kodlarınıza ilaveleri en sona eklemek en basit çözümdür.

Aşağıdaki kodları deneyiniz.

Kod: 
DefStr S
    DefInt A
    Private Sub Worksheet_Change(ByVal Target As Range)
[COLOR="Red"]    On Error GoTo hatabir[/COLOR]
    Dim tip As VbMsgBoxStyle, yanit As VbMsgBoxResult
    a = Target.Row
    If Target.Row > 1 And Target.Column = 3 And Target.Value <> "" Then
    adet1 = WorksheetFunction.CountIf(Range("c2:c" & Range("c65536").End(3).Row), Target.Value)
    If adet1 > 1 Then
        tip = vbQuestion + vbYesNo
        soru1 = "Mükkerrer kayıt bulundu"
        soru2 = "İşleme devam edilsin mi ? "
        yanit = MsgBox(soru1 & vbNewLine & soru2, tip, "MÜKERRER KAYIT")
        If yanit = vbNo Then
            Target.Value = Empty
            Exit Sub
        End If
    End If
    End If
    If Target.Row > 1 And (Target.Column = 4 Or Target.Column = 5) And Target.Value <> "" Then
    adet1 = WorksheetFunction.CountIf(Range("c2:c" & Range("c65536").End(3).Row), Range("c" & a).Value)
    adet2 = WorksheetFunction.CountIf(Range("d2:d" & Range("d65536").End(3).Row), Range("d" & a).Value)
    adet3 = WorksheetFunction.CountIf(Range("e2:e" & Range("c65536").End(3).Row), Range("e" & a).Value)
    If adet1 > 1 And adet2 > 1 And adet3 > 1 Then
        MsgBox "Mükerrer kayıt bulundu. İşleme devam edilemiyor. " & vbNewLine & _
        "Yazılan bilgiler silinecektir.", vbExclamation, "MÜKERRER KAYIT"
        Range("c" & a).Value = Empty
        Range("d" & a).Value = Empty
        Range("e" & a).Value = Empty
        End If
    End If
    soru1 = vbNullString: soru2 = vbNullString
    a = Empty: adet1 = Empty: adet2 = Empty: adet3 = Empty
    yanit = Empty: tip = Empty
    
[COLOR="Red"]hatabir:[/COLOR]
        If Intersect(Target, [C:E]) Is Nothing Then Exit Sub
        On Error GoTo hata
        
        Cells(Target.Row, "N") = Format(Now, "dd.mm.yyyy - hh:mm")
        If Cells(Target.Row, "M") = "" Then
        Cells(Target.Row, "M") = Format(Now, "dd.mm.yyyy - hh:mm")
        End If
        
        sa = Target.Row
        If WorksheetFunction.CountA(Range("C" & sa & ":E" & sa)) = 0 Then
        Cells(Target.Row, "M") = ""
        Cells(Target.Row, "N") = ""
        End If
hata:
        
    End Sub

. . .
 
Son düzenleme:
Sayın vardar07 ve Hüseyin Çoban,

Yeni kodlar gayet güzel çalışıyor. Ancak, C,D ve E sütunlarını birlikte seçerek Delet tusuna ile silmeye çalıştığımda "Run-time eror'13': Type mismatch" hatası vererek devamında "If Target.Row > 1 And Target.Column = 3 And Target.Value <> "" Then" satırını göstermektedir. Ama hüçreleri tek tek silince herhangi bir sorun olmamaktadır.

Saygılarımla.
 
Son düzenleme:
. . .

Bu hata eski kodlarınızdan kaynaklanıyor.
Toplu silme yaptığınızda başınıza daha öncede geliyor olması gerekiyor.
Yukarıdaki kodlara kırmızı ile belirttiğim satırları ilave ettim. Deneyiniz.

. . .
 
Sayın Hüseyin Çoban,

Şimdi hata mesajını almıyorum ama, şöyle küçük bir sorun daha var. C,D, ve E sütunlarındaki birden fazla satırlar silinmek istendiğinde ise sadece bir satıra (Silinmek istenen seçimdeki ilk satıra) ait kayıt ve değişiklik tarihlerini siliyor. Silinen diğer kayıtlara ait tarihleri silmek için zaten boş olan satırlara ayrı ayrı delete tuşuna basarak silmek durumda kalıyorum.

Saygılarımla.
Ömer Ali ÜZÜMCÜ
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst