Vba ile Çift Veri Girişi Engelleme

[sakaryatuna]

Merhabalar,

$C$3:$C$2000 aralığında tarihler var,
$D$3:$D$2000 aralığında "veri doğrulama ile gelen" veriler var

İstediğim, aynı tarihe çift veri girişini engellemek/uyarı almak
Aynı tarih birkaç tane olabilir;

C Sütunu D Sütunu veri
08.11.2023 Ankara
08.11.2023 İstanbul
08.11.2023 İzmir ... olabilir,

C Sütunu D Sütunu veri
08.11.2023 Ankara
08.11.2023 Ankara .......olduğunda aynı tarihe aynı veri girişini Vba kodu ile engelleyebilir miyiz?

Bu kodu herhangi butona bağlamayacağız, yukarıda izah ettiğim durumda dinamik olarak çalışacak.
Yardımcı olursanız sevinirim.

 

[DoğanD]

Merhaba,

Sayfanın kod bölümüne yapıştırıp dener misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 4 Then
If WorksheetFunction.CountIfs(Range("c:c"), Cells(Target.Row, Target.Column - 1), Range("d:d"), Target.Value) > 1 Then
MsgBox "Bu giriş zaten var!", vbCritical, "Mükerrer Giriş"
Target.Value = ""
Target.Select
End If
End If
If Target.Column = 3 Then
If WorksheetFunction.CountIfs(Range("c:c"), Target.Value, Range("d:d"), Cells(Target.Row, Target.Column + 1)) > 1 Then
MsgBox "Bu giriş zaten var!", vbCritical, "Mükerrer Giriş"
Target.Value = ""
Target.Select
End If
End If
End Sub

 

[Levent Menteşoğlu]

Aşağıdaki gibide deneyebilirsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Range("C3:D1000")) Is Nothing Then Exit Sub

tarih = Cells(Target.Row, "C").Value
iladi = Cells(Target.Row, "D").Value

If tarih = "" Or iladi = "" Then Exit Sub

satir = Target.Row - 1

formul = "=SUMPRODUCT((C3:C" & satir & "=" & CLng(tarih) & ")*(D3:D" & satir & "=""" & iladi & """))"

say = Evaluate(formul)

If say > 0 Then
MsgBox "Bu veri daha önceden girilmiştir.", 32, "Uyari"
Exit Sub
End If

End Sub

 

[sakaryatuna]

Merhaba Doğan Bey,
Denedim, istediğim gibi çalıştı. Alakanıza çok teşekkür ederim.

Ancak denemek için birkaç tarih yazdım. Yazdığım tarihleri silince kod hatası alıyorum.
Daha sonra fazladan tarih yazılmış ve silinecek olsa yine hata verir sanırım

 

[sakaryatuna]

Size de teşekkür ederim Levent Bey,
Uyarı verdi, ancak engelleme yapmıyor, mükerrer kayıt yapmaya devam edebiliyorsunuz

 

[sakaryatuna]

If WorksheetFunction.CountIfs(Range("c:c"), Target.Value, Range("d:d"), Cells(Target.Row, Target.Column + 1)) > 1 Then

Bu kısımda hata veriyor

 

[DoğanD]

Merhaba Doğan Bey,
Denedim, istediğim gibi çalıştı. Alakanıza çok teşekkür ederim.

Ancak denemek için birkaç tarih yazdım. Yazdığım tarihleri silince kod hatası alıyorum.
Daha sonra fazladan tarih yazılmış ve silinecek olsa yine hata verir sanırım

Merhaba,

Kodları aşağıdaki gibi revize ettim, dener misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Value = "" Then Exit Sub
If Target.Column = 4 Then
If WorksheetFunction.CountIfs(Range("c:c"), Cells(Target.Row, Target.Column - 1), Range("d:d"), Target.Value) > 1 Then
GoTo tekrar
End If
End If

If Target.Column = 3 Then
If WorksheetFunction.CountIfs(Range("c:c"), Target.Value, Range("d:d"), Cells(Target.Row, Target.Column + 1)) > 1 Then
GoTo tekrar
End If
End If

Exit Sub
tekrar:
MsgBox "Bu giriş zaten var!", vbCritical, "Mükerrer Giriş"
Target.Value = ""
Target.Select
End Sub

 

[sakaryatuna]

Merhabalar,
C ve D hücrelerindeki verilerin birkaç tanesini seçip "delete" yapınca şu kodda hata veriyor: If Target.Value = "" Then
Hücredeki veriler teker teker sildiğinizde hata vermiyor.

 

[DoğanD]

Bir de bu kodu dener misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo son
If Target.Value = "" Then Exit Sub
If Target.Column = 4 Then
If WorksheetFunction.CountIfs(Range("c:c"), Cells(Target.Row, Target.Column - 1), Range("d:d"), Target.Value) > 1 Then
GoTo tekrar
End If
End If

If Target.Column = 3 Then
If WorksheetFunction.CountIfs(Range("c:c"), Target.Value, Range("d:d"), Cells(Target.Row, Target.Column + 1)) > 1 Then
GoTo tekrar
End If
End If

Exit Sub
tekrar:
MsgBox "Bu giriş zaten var!", vbCritical, "Mükerrer Giriş"
Target.Value = ""
Target.Select
son:
End Sub

 

[sakaryatuna]

İstediğim gibi oldu, ilginize çok teşekkür ederim.
Emeğinize sağlık.

 

[sakaryatuna]

Sonraki günlerde C sütününe tarih kriteri (mesela aynı tarihten en fazla 5 kayıt gibi ) koyacak olsam nasıl yapabilirim.
Gönderdiğiniz koddan bağımsız olarak

 

[DoğanD]

Yine bu kod ile birlikte kullanacağınızı varsayarak birleştirdim fakat renkli bölümü ayrıca da kullanabilirsiniz. Giriş sayısını 4 rakamını değiştirerek ayarlayabilirsiniz.

Edit: Bu kod Kopyala-yapıştır ile eklenen birden fazla veriyi kontrol edemez. Sadece satır girişi için çalışacaktır.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo son
If Target.Value = "" Then Exit Sub
If Target.Column = 4 Then
If WorksheetFunction.CountIfs(Range("c:c"), Cells(Target.Row, Target.Column - 1), Range("d:d"), Target.Value) > 1 Then
GoTo tekrar
End If
End If

If Target.Column = 3 Then
'-----
If WorksheetFunction.CountIf(Range("C:C"), Target.Value) > 4 Then
MsgBox Format(Target.Value, "DD.MM.YYYY") & " Tarihi için azami giriş sayısı aşıldı!"
Target.Value = ""
Target.Select
Exit Sub
End If
'-----
If WorksheetFunction.CountIfs(Range("c:c"), Target.Value, Range("d:d"), Cells(Target.Row, Target.Column + 1)) > 1 Then
GoTo tekrar
End If
End If

Exit Sub
tekrar:
MsgBox "Bu giriş zaten var!", vbCritical, "Mükerrer Giriş"
Target.Value = ""
Target.Select
son:
End Sub

 

[Korhan Ayhan]

Alternatif olarak arşiv konularını da inceleyebilirsiniz.

Arşiv Konuları