Mükerrer Verilerin Silinmesi

[alperalper]

Arkadaşlar ben mükerrer verileri sildirmek istiyorum ama bir türlü başaramadım. B - C - D - E sütunlarındaki veriler aynı ise o satırı kaldırmasını istiyorum. Ya da veri girişi yaparken bu dört tane A B C D E sütunlarındaki veriler aynı olursa hata versin ekleme yapmasın... Bu şekilde olursa daha güzel olur. Saygılar..

 

[İhsan Tank]

Arkadaşlar ben mükerrer verileri sildirmek istiyorum ama bir türlü başaramadım. B - C - D - E sütunlarındaki veriler aynı ise o satırı kaldırmasını istiyorum. Ya da veri girişi yaparken bu dört tane A B C D E sütunlarındaki veriler aynı olursa hata versin ekleme yapmasın... Bu şekilde olursa daha güzel olur. Saygılar..

merhaba
özellikle istediğiniz aynı veri varsa eklemesin dediğinizi dosyanıza yaptım
makro ile
thisworkbook bölümüne bakınız

 

[alperalper]

merhaba
özellikle istediğiniz aynı veri varsa eklemesin dediğinizi dosyanıza yaptım
makro ile
thisworkbook bölümüne bakınız

kardeş ilgin için teşekkür ederim fakat istediğim bu değil. benim istediğim 4 sütundaki veriler aynı olunca işlem yapacak. yoksa aynı kişi adına hem rapor hem senelik izni giriyoruz zaten. girmemiz gerekiyor. tam olarak anlatabildim mi? yada mükerrer verileri silmek için buton yapabilirmisin? ben yaptım fakat kriter olarak tek sütuna bakıyordu bunu silerken 4 sütun kriterini değerlendirmesini istiyorum.

 

[İhsan Tank]

kardeş ilgin için teşekkür ederim fakat istediğim bu değil. benim istediğim 4 sütundaki veriler aynı olunca işlem yapacak. yoksa aynı kişi adına hem rapor hem senelik izni giriyoruz zaten. girmemiz gerekiyor. tam olarak anlatabildim mi? yada mükerrer verileri silmek için buton yapabilirmisin? ben yaptım fakat kriter olarak tek sütuna bakıyordu bunu silerken 4 sütun kriterini değerlendirmesini istiyorum.

aynı derken nasıl olacak
bilgi verin isterseniz yada örnek dosya üzerinde açıklayınız

 

[alperalper]

aynı derken nasıl olacak
bilgi verin isterseniz yada örnek dosya üzerinde açıklayınız

kardeş örnek dosya içerisinde açıkladım zaten. ben diyorum ki sadece bir kritere göre değil birden fazla kritere göre değerlendirme yapsın. mesela ben yapmıştım mükerrer verileri silmeyi ama sadece isime göre mükerrer olanları sildi. ama ben aynı isimden veriler giriyorum onda sıkıntı yok. aynı isimde aynı başlangıç tarihinde aynı gün sayısı kadar izni olan ve aynı tür izni olan mesela senelik izin gibi olanları silmek istiyorum. yani kısacası mustafa isimli kişiye iki defa aynı tarihte başlayan yıllık izin girmemek için. ama bu kişiye hem yıllık izin hem rapor girebilirim. anlatabildim umarım.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu ilgili sayfanın kod bölümüne uygulayıp denermisiniz. Eski kodu silip uygulayın.

Not: Kod çoklu seçimlerde sağlıklı çalışmaz.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim BUL As Range, ADRES As String
    
    On Error GoTo Son
    
    If Intersect(Target, Range("B2:E65536")) Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    If Target.Column = 3 Or Target.Column = 4 Then
        Cells(Target.Row, "V").ClearContents
        If Target <> "" Then
            If IsNumeric(Target) = True Or IsDate(Target) = True Then
                Cells(Target.Row, "V").Value = Date
            End If
        End If
    End If
        
    If WorksheetFunction.CountA(Range(Cells(Target.Row, "B"), Cells(Target.Row, "E"))) = 4 Then
        If Cells(Target.Row, "B") <> "" Then
            If WorksheetFunction.CountIf(Range("B:B"), Cells(Target.Row, "B")) > 1 Then
                Set BUL = Range("B:B").Find(Cells(Target.Row, "B"))
                If Not BUL Is Nothing Then
                    ADRES = BUL.Address
                    Do
                        If Target.Row <> BUL.Row Then
                            If BUL.Offset(0, 1) = Cells(Target.Row, "C") And _
                            BUL.Offset(0, 2) = Cells(Target.Row, "D") And _
                            BUL.Offset(0, 3) = Cells(Target.Row, "E") Then
                                Mesaj = IIf(Mesaj = Empty, BUL.Address(0, 0), Mesaj & " , " & BUL.Address(0, 0))
                            End If
                        End If
                    Set BUL = Range("B:B").FindNext(BUL)
                    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
                End If
                
                If Mesaj <> Empty Then
                    Range("B" & Target.Row & ":E" & Target.Row).ClearContents
                    Cells(Target.Row, "B").Select
                    Application.ScreenUpdating = True
                    MsgBox "Bu kayıt daha önce aşağıdaki hücrede girilmiştir !" & vbCrLf & vbCrLf & Mesaj, vbCritical, "Mükerrer Kayıt !"
                End If
            End If
        End If
    End If
 
Son:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

 

[alperalper]

Selamlar,

Aşağıdaki kodu ilgili sayfanın kod bölümüne uygulayıp denermisiniz. Eski kodu silip uygulayın.

Not: Kod çoklu seçimlerde sağlıklı çalışmaz.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim BUL As Range, ADRES As String
    
    On Error GoTo Son
    
    If Intersect(Target, Range("B2:E65536")) Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    If Target.Column = 3 Or Target.Column = 4 Then
        Cells(Target.Row, "V").ClearContents
        If Target <> "" Then
            If IsNumeric(Target) = True Or IsDate(Target) = True Then
                Cells(Target.Row, "V").Value = Date
            End If
        End If
    End If
        
    If WorksheetFunction.CountA(Range(Cells(Target.Row, "B"), Cells(Target.Row, "E"))) = 4 Then
        If Cells(Target.Row, "B") <> "" Then
            If WorksheetFunction.CountIf(Range("B:B"), Cells(Target.Row, "B")) > 1 Then
                Set BUL = Range("B:B").Find(Cells(Target.Row, "B"))
                If Not BUL Is Nothing Then
                    ADRES = BUL.Address
                    Do
                        If Target.Row <> BUL.Row Then
                            If BUL.Offset(0, 1) = Cells(Target.Row, "C") And _
                            BUL.Offset(0, 2) = Cells(Target.Row, "D") And _
                            BUL.Offset(0, 3) = Cells(Target.Row, "E") Then
                                Mesaj = IIf(Mesaj = Empty, BUL.Address(0, 0), Mesaj & " , " & BUL.Address(0, 0))
                            End If
                        End If
                    Set BUL = Range("B:B").FindNext(BUL)
                    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
                End If
                
                If Mesaj <> Empty Then
                    Range("B" & Target.Row & ":E" & Target.Row).ClearContents
                    Cells(Target.Row, "B").Select
                    Application.ScreenUpdating = True
                    MsgBox "Bu kayıt daha önce aşağıdaki hücrede girilmiştir !" & vbCrLf & vbCrLf & Mesaj, vbCritical, "Mükerrer Kayıt !"
                End If
            End If
        End If
    End If
 
Son:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Teşekkür ederim korhan kardeş... Şuan bir sorun yok gibi görünüyor. Çalışıyor eğer sorun olursa o zaman bakarız bir hal çerisine. Teşekkür ediyorum....