• DİKKAT

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

Aynı bilgi girişini önle

  • Konbuyu başlatan Konbuyu başlatan m.gur
  • Başlangıç tarihi Başlangıç tarihi
M

m.gur

Katılım
9 Temmuz 2004
Mesajlar
427
Excel Vers. ve Dili
Office 2007 Tr & Office 2019 Tr
Merhaba;ben yapmaya çalıştım ama sonuca ulaşamadım. Aktarma yaparken mükerrer kaydı buluyorum fakat silme işlemini bir türlü beceremedim. A sütununa göre aynı kayıt varsa buluyor. İstediğim şu; aynı kayıt varsa tekrar kayıt yapmasın yaptıysa da o satırı silsin. Sanırım açıklayabilmişimdir. Teşekkürler.
 

Ekli dosyalar

m.gur' Alıntı:
Merhaba;ben yapmaya çalıştım ama sonuca ulaşamadım. Aktarma yaparken mükerrer kaydı buluyorum fakat silme işlemini bir türlü beceremedim. A sütununa göre aynı kayıt varsa buluyor. İstediğim şu; aynı kayıt varsa tekrar kayıt yapmasın yaptıysa da o satırı silsin. Sanırım açıklayabilmişimdir. Teşekkürler.
Genişletmek için tıkla ...

merhaba
dosyanızın thisworkbook bölümüne
Kod: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Range("A1:A65536")) Is Nothing Or Target = "" Then Exit Sub
For x = 1 To Sheets.Count
Say = WorksheetFunction.CountIf(Sheets(x).Range("A1:A65536"), Target)
knt = knt + Say
Next
If knt > 1 Then
MsgBox "Bu veri daha önce girilmiş.", vbCritical, "UYARI"
Target = ""
End If
End Sub
bu kodu yapıştırnız
 

Ekli dosyalar

Son düzenleme:
Merhaba,

Veri - Doğrulama adımlarını takip ederek gelen listede özel seçeneğini seçip aşağıdaki formülü oraya yazınız.

=eğersay(A:A;A2)=1

Bu formül satıra mükerrer kayıt girişini engeller.

kolay gelsin
 
If Intersect(Target, Range("A1:A65536")) Is Nothing Or Target = "" Then Exit Sub
Bu satırda hata veriyor. Veriyi de kayıt ediyor yine.
 
Sayın İhsan zaten eklediğiniz dosyayı çalıştırdım. Şu an tekrar denedim yine aynı.
 
m.gur' Alıntı:
Merhaba;ben yapmaya çalıştım ama sonuca ulaşamadım. Aktarma yaparken mükerrer kaydı buluyorum fakat silme işlemini bir türlü beceremedim. A sütununa göre aynı kayıt varsa buluyor. İstediğim şu; aynı kayıt varsa tekrar kayıt yapmasın yaptıysa da o satırı silsin. Sanırım açıklayabilmişimdir. Teşekkürler.
Genişletmek için tıkla ...

Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
For a = [a65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, "a")) > 1 Then Rows(a).Delete
Next
End Sub
deneyin VERI in kod bölümüne yazın...
 
Son düzenleme:
Hepinize teşekkür ederim ama malesef çalışmadı.
 
verdiğim kodları VERI sayfasının kod bölümüne ekleyin
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
For a = [a65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, "a")) > 1 Then Rows(a).Delete
Next
End Sub
Genişletmek için tıkla ...
ekleyin ve
kayıt yaptınız sayfaya açıp her hangi bir hücreye tıklayın...
 
Bu kodla dediğiniz oluor fakat kullanışlı değil. Benim stediğim eğer kayıt daha önce mevcutsa "BU KAYIT MEVCUT" desin ve kaydetmesin , yada kaydettiyse silsin. Dosyayı tekrar ekliyorum.
 

Ekli dosyalar

alternatif kod
diğer kodların hepsini sil
bu kod kayıt esnasında mükerrer kayıtları yapmıyor.

Sub aktar()
Dim sf As Worksheet
Dim sv As Worksheet
Dim i As Long
Set sf = Sheets("FORM 1")
Set sv = Sheets("VERI")
If WorksheetFunction.CountIf(sv.Range("a1:a65500"), sf.Range("AN5")) > 0 Then: MsgBox "bu kayıt daha önce girildi": Exit Sub
cevap = MsgBox(Prompt:="Yapılan değişiklikleri kabul ediyor musunuz?", Buttons:=vbQuestion + vbYesNo)
If cevap <> vbYes Then GoTo 20
i = sv.[A65536].End(3).Row + 1
sv.Cells(i, "A") = sf.Range("AN5")
sv.Cells(i, "B") = sf.Range("AN12")
sv.Cells(i, "C") = sf.Range("B18")
sv.Cells(i, "D") = sf.Range("E18")
sv.Cells(i, "E") = sf.Range("L18")
sv.Cells(i, "F") = sf.Range("T18")
sv.Cells(i, "G") = sf.Range("X18")
sv.Cells(i, "H") = sf.Range("AB18")
sv.Cells(i, "I") = sf.Range("AK18")
sv.Cells(i, "J") = sf.Range("G22")
sv.Cells(i, "K") = sf.Range("AT34")
sv.Cells(i, "L") = sf.Range("Y38")
sv.Cells(i, "M") = sf.Range("AN37")
MsgBox Prompt:="Değişiklikler kaydedildi!"
'End If
End
20
MsgBox "Veriler Aktarılamadı"
End
End Sub
Genişletmek için tıkla ...
 
Sayın halit3; çok teşekkür ederim. Kodlar tamam şimdilik sorun yok. Elinize sağlık. İyi çalışmalar.
 
Aynı konu olduğu için bu başlığa keni sorumu yazıyorum..

form ve kütük adlı 2 sayfam var.Userform ile aşağıdaki kodlarla kütük sayfasına veri kaydediyorum.
Kayıt sırasında aynı kaydın olduğuna dair ikaz veriyor ama kütük sayfasının A sütünü kontrol edip Aynı kişi var diyor.
Oysa benim kütük sayfasında TC Kimlik numaramın bulunduğu sütun 4.sütunda.

Sorgulamayı 4.sütuna bakarak yapsın istedim ama yapamadım..
Kırmızı satırı nasıl düzenlemeliyim..YAda alternatif bir kodda olabilir.

-Kütük Sayfasının D Sütuna TC kaydediyor.TC Kontrol ederek kaydı önlesin.

TC Kimlik TextBox70'de kaydediyor.
Kodlar:

Kod: 
Sheets("kütük").Activate
If TextBox92.Value <> "" Then
[COLOR=darkred]Cells(1, 1).Select[/COLOR]
[COLOR=darkred]Do While ActiveCell.Value <> ""[/COLOR]
[COLOR=darkred]If Trim(ActiveCell.Value) = Trim(Me.TextBox92.Value) Then[/COLOR]
[COLOR=darkred]If MsgBox(Me.TextBox92 & " Sıra Numaralı kayıt Vardır." & " Yeniden Kayıt Yapılsın mı?", vbYesNo, "Mükerrer Kayıt") = vbNo Then Exit Sub[/COLOR]
[COLOR=darkred]End If[/COLOR]
ActiveCell.Offset(1, 0).Activate
Loop
On Error Resume Next
ActiveCell.Value = TextBox92.Value
ActiveCell.Offset(0, 1).Value = TextBox92.Value
ActiveCell.Offset(0, 2).Value = TextBox100.Value
ActiveCell.Offset(0, 3).Value = TextBox70.Value
ActiveCell.Offset(0, 4).Value = TextBox71.Value
ActiveCell.Offset(0, 5).Value = TextBox72.Value
ActiveCell.Offset(0, 6).Value = TextBox73.Value
End If
MsgBox "Kayıt Tamamlandı..."
End Sub
 
htsumer' Alıntı:
Aynı konu olduğu için bu başlığa keni sorumu yazıyorum..

form ve kütük adlı 2 sayfam var.Userform ile aşağıdaki kodlarla kütük sayfasına veri kaydediyorum.
Kayıt sırasında aynı kaydın olduğuna dair ikaz veriyor ama kütük sayfasının A sütünü kontrol edip Aynı kişi var diyor.
Oysa benim kütük sayfasında TC Kimlik numaramın bulunduğu sütun 4.sütunda.

Sorgulamayı 4.sütuna bakarak yapsın istedim ama yapamadım..
Kırmızı satırı nasıl düzenlemeliyim..YAda alternatif bir kodda olabilir.

-Kütük Sayfasının D Sütuna TC kaydediyor.TC Kontrol ederek kaydı önlesin.

TC Kimlik TextBox70'de kaydediyor.
Genişletmek için tıkla ...

örnek dosya eklermisiniz
 
K.Bakmayın çalışıyordum görmedim yazınızı.

Dosya çok karışık olduğundan eklemedim..Bir tane hazırlarım şimdi..
 
Dosyayı ayıkladım örnek çıkarıp ekledim.
 

Ekli dosyalar

htsumer' Alıntı:
Dosyayı ayıkladım örnek çıkarıp ekledim.
Genişletmek için tıkla ...

iyi geceler
kodu bu şekilde değiştirdim
Kod: 
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
If TextBox92.Value <> "" Then
Cells(1, 1).Select
Do While ActiveCell.Value <> ""
If Trim(ActiveCell.Value) = Trim(Me.TextBox92.Value) Then
If MsgBox(Me.TextBox92 & " Sıra Numaralı kayıt Vardır." & " Yeniden Kayıt Yapılsın mı?", vbYesNo, "Mükerrer Kayıt") = vbNo Then Exit Sub
End If
ActiveCell.Offset(1, 0).Activate
Loop
On Error Resume Next
If WorksheetFunction.CountIf(Range("D:D"), TextBox70.Text) > 0 Then
MsgBox "Böyle bir kayıt var.", , "www.excel.web.tr"
Exit Sub
End If
ActiveCell.Value = TextBox92.Value
Sheets("form").Range("a2") = TextBox92.Value
ActiveCell.Offset(0, 1).Value = TextBox92.Value
ActiveCell.Offset(0, 2).Value = TextBox100.Value
ActiveCell.Offset(0, 3).Value = TextBox70.Value
ActiveCell.Offset(0, 4).Value = TextBox71.Value
ActiveCell.Offset(0, 5).Value = TextBox72.Value
ActiveCell.Offset(0, 6).Value = TextBox73.Value
End If
MsgBox "Kayıt Tamamlandı.", , "www.excel.web.tr"
End Sub
örnek dosya ekte inceleyiniz
 

Ekli dosyalar

İhsan bey,
İlginiz için teşekkür ederim.Bu sabah deneme fırsatımoldu.Gayet güzel oldu.Elinize sağlık teşekkür ederim..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst