Mükerrer kaydı engellemek istiyorum.

[s.savas]

Merhaba arkadaşlar.
Aşağıdaki koda TextBox6 referans alınarak mükerrer kayıt yapmamak için gerekli düzenlemeyi yapamadım.

Private Sub cmdKAYDET_Click()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Satır As Long, k As Byte, S As Worksheet
Dim sor
Set S = ActiveSheet
Satır = S.Range("A65536").End(3).Row + 1

If TextBox7.Value = "" Then
TextBox7.SetFocus
MsgBox ("Lütfen Tarih Giriniz"), vbInformation, "s.s."
Exit Sub
End If


If ComboBox1.Value = "" Then
ComboBox1.SetFocus
MsgBox ("Lütfen 1.Nöbetçiyi Giriniz"), vbInformation, "s.s."
Exit Sub
End If

If ComboBox2.Value = "" Then
ComboBox2.SetFocus
sor = MsgBox("2.Nöbetçi girilmedi; yine de kayıt yapılsın mı?", vbYesNo, "s.s.")
If sor = vbNo Then Exit Sub
End If

If ComboBox1.Value = ComboBox2.Value Then
ComboBox2.SetFocus
MsgBox ("Her iki nöbetçi aynı kişi olamaz"), vbInformation, "s.s."
Exit Sub
End If

If TextBox6.Value = "" Then
TextBox6.SetFocus
MsgBox ("Lütfen Protokol Numarasını Giriniz"), vbInformation, "s.s."
Exit Sub
End If


If TextBox2.Value = "" Then
TextBox2.SetFocus
MsgBox ("Lütfen Çıkış Km sini Giriniz"), vbInformation, "s.s."
Exit Sub
End If

If TextBox3.Value = "" Then
TextBox3.SetFocus
MsgBox ("Lütfen Dönüş Km sini Giriniz"), vbInformation, "s.s."
Exit Sub
End If

If TextBox3 <> 0 And Val(TextBox3.Text) < Val(TextBox2.Text) Then
MsgBox ("Dönüş Km si Çıkış Km sinden Küçük Olamaz."), vbInformation, "s.s."
TextBox3.SetFocus
Exit Sub
End If

TextBox5.Text = Val(TextBox3) - Val(TextBox2)
S.Cells(Satır, "A").Value = TextBox7.Value 'Kayıt Tarihi
S.Cells(Satır, "A").HorizontalAlignment = xlCenter
S.Cells(Satır, "B").Value = TextBox6.Value 'pROTOKOL
S.Cells(Satır, "B").HorizontalAlignment = xlCenter
S.Cells(Satır, "C").Value = ComboBox1.Value 'Nöbetçi 1
S.Cells(Satır, "D").Value = ComboBox2.Value 'Nöbetçi 2
S.Cells(Satır, "BW").Value = TextBox2.Value 'Çıkış Km
S.Cells(Satır, "BX").Value = TextBox3.Value 'Dönüş Km
S.Cells(Satır, "BZ").Value = TextBox4.Value 'Alınan Yakıt
S.Cells(Satır, "BZ").NumberFormat = "#,##0.00"
S.Cells(Satır, "BY").Value = TextBox5.Value 'Yapılan Km


If OptionButton1.Value = True Then
S.Cells(Satır, "E").Value = "1"
S.Cells(Satır, "E").HorizontalAlignment = xlCenter
End If
End Sub

 

[s.savas]

Arkadaşlar forumdan alıntı yaptığım aşağıdaki kodlar ile yapmaya çalışıyorum, fakat bütün gün deneme yanılma yapmama rağmen başaramadım. Sürekli bir yerlerde hata verdi.

Private Sub cmdKAYDET_Click()
On Error Resume Next
Dim bak As Range
Dim say As Integer

For Each bak In Range("c4:c" & WorksheetFunction.CountA(Range("c4:c65000")))
If bak.Value = TextBox2.Value Then
MsgBox "Bu kayıt numarası bulundu."
Exit Sub
End If

If TextBox2.Text = "" Then
MsgBox "Lütfen protokol no'sunu girin...", , "Kayıt Hatası!!!"
Exit Sub
End If

Next bak

For Each bak In Range("C4:C" & WorksheetFunction.CountA(Range("C4:C65000")))
If StrConv(bak.Value, vbUpperCase) = StrConv(TextBox2.Value, vbUpperCase) Then
MsgBox "Bu protokola ait bir kaydınız bulundu"
Exit Sub
End If
     
Next bak
say = WorksheetFunction.CountA(Range("C4:C65500"))
Label18 = say
Cells(say + 4, 1).Value = Label18 * 1
Cells(say + 4, 2).Value = TextBox1.Value
Cells(say + 4, 3).Value = TextBox2.Value
Cells(say + 4, 4).Value = ComboBox1.Value
Cells(say + 4, 5).Value = ComboBox2.Value

    
MsgBox "Yeni Kayıt Başarıyla Yapılmıştır.İyi Çalışmalar Dilerim", vbInformation, "Sn.  " & Application.UserName

Label18.Caption = WorksheetFunction.Count(Range("A4:A65500")) + 1
Unload UserForm1
UserForm1.Show

End Sub

 

[Ömer]

Merhaba,

Bu şekilde deneyiniz.

Private Sub cmdKAYDET_Click()
Dim say As Long, son As Long
 
If TextBox2.Text = "" Then
    MsgBox "Lütfen protokol no'sunu girin...", , "Kayıt Hatası!!!"
    Exit Sub
End If
 
say = WorksheetFunction.CountIf(Range("C5:C" & Rows.Count), TextBox2.Text)
If say > 0 Then
    MsgBox "Bu kayıt numarası bulundu."
    Exit Sub
End If
 
son = Cells(Rows.Count, "C").End(xlUp).Row + 1
Label18 = son - 4
Cells(son, "A").Value = Label18 * 1
Cells(son, "B").Value = TextBox1.Value
Cells(son, "C").Value = TextBox2.Value
Cells(son, "D").Value = ComboBox1.Value
Cells(son, "E").Value = ComboBox2.Value
 
MsgBox "Yeni Kayıt Başarıyla Yapılmıştır.İyi Çalışmalar Dilerim", _
        vbInformation, "Sn.  " & Application.UserName
 
Label18.Caption = son
Unload UserForm1
UserForm1.Show
 
End Sub

.

 

[s.savas]

Hocam Allah razı olsun. Çok teşekkür ederim.