Y

Çözüldü mükerrer kaydı önleme

  • Konuyu başlatan Konuyu başlatan YAMAHATO
  • Başlangıç tarihi Başlangıç tarihi
Y

YAMAHATO

Normal Üye
Excel Versiyonu
Excel 2016
Excel Sürümü
64 Bit
Excel Dili
Türkçe
Kod: 
Görüntülemek için giriş yapmanız gerekmektedir.
(31 satır)

Merhaba
yukarıda ki kod userform 2 de girilen verileri SAHİBİNDEN isimli sayfaya kaydediyor.
söyle bir sorunum var. MÜKERRER KAYITI ÖNLEME
Textbox1'e girilen değer sahibinden sayfasında A2 hücresinden itibaren ne kadar hücre varsa ARAYIP AYNISINI GÖRÜRSE
mükerrer kayıt yazsın. İnternetten bir sürü kod buldum ama kodu bir türlü ayarlayamadım ve çalıştıramadım.
 

Ekli dosyalar

Moderatörün son düzenlenenleri:
Tarihe göre sırala Oylamaya göre sırala
Ömer BARAN' Alıntı:
Merhaba Sayın @YAMAHATO .

Kodda ilgili yere, aşağıda yeşil renklendirdiğim satırları ekleyerek deneyin.

Kod: 
Görüntülemek için giriş yapmanız gerekmektedir.
(11 satır)
Genişletmek için tıklayın ...
Ömer Hocamızın müsaadesiyle bir kod'ta ben ekleyeyim.

Private Sub Mukerrer()

Dim conMük As Object: Dim rsMük As Object

MsgBox " Mükerrer çalıştı."

Set conMük = CreateObject("Adodb.Connection")

Set rsMük = CreateObject("adodb.recordset")

conMük.Open "provider=microsoft.jet.oledb.4.0;data source=" & _

ThisWorkbook.FullName & ";extended properties=""Excel 8.0;hdr=yes"""

rsMük.Open "select [SAHİBİNDEN NO] from [SAHİBİNDEN$A1:A]", conMük, 1, 3

Do While Not rsMük.EOF

If rsMük("SAHİBİNDEN NO").Value = Me.TextBox1.Text Then

MsgBox " Bu Parça Kayıtlıdır. ", vbExclamation, "SAT'S"

Var = True

Exit Sub

End If:

rsMük.MoveNext

Loop

If Var = False Then

Call CommandButton1_Click

End If

rsMük.Close: conMük.Close

Set conMük = Nothing: Set rsMük = Nothing

End Sub[/CODE]
 
Moderatörün son düzenlenenleri:
Oyla 0 Olumsuz oyla
MESKO' Alıntı:
Ömer Hocamızın müsaadesiyle bir kod'ta ben ekleyeyim.

Private Sub Mukerrer()

Dim conMük As Object: Dim rsMük As Object

MsgBox " Mükerrer çalıştı."
Set conMük = CreateObject("Adodb.Connection")
Set rsMük = CreateObject("adodb.recordset")

conMük.Open "provider=microsoft.jet.oledb.4.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 8.0;hdr=yes"""

rsMük.Open "select [SAHİBİNDEN NO] from [SAHİBİNDEN$A1:A]", conMük, 1, 3

Do While Not rsMük.EOF
If rsMük("SAHİBİNDEN NO").Value = Me.TextBox1.Text Then
MsgBox " Bu Parça Kayıtlıdır. ", vbExclamation, "SAT'S"
Var = True
Exit Sub
End If:
rsMük.MoveNext
Loop
If Var = False Then

Call CommandButton1_Click

End If
rsMük.Close: conMük.Close
Set conMük = Nothing: Set rsMük = Nothing
End Sub
Genişletmek için tıklayın ...
bu kodu tam olarak nereye ekleyeceğim.
 
Oyla 0 Olumsuz oyla
Yanıt için giriş yapmanız veya üye olmanız gerekir.
Üst