• DİKKAT

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

mükerrer kaydı engelleyemedim

O

ockucukay

Katılım
29 Aralık 2005
Mesajlar
862
Excel Vers. ve Dili
Office 365 Türkçe
Merhaba arkadaşlar

Forumdaki tüm mükerrer kayıt örneklerini inceledim. Benimkine benzer birkaç çalışma buldum ancak dosyaları çalışmadı veya indiremedim. Yapmak istediğim şey: Yetkili Giriş sayfasında tüm alanları doldurup kaydet (disket) düğmesine bastığım zaman (YETKILI) sayfasında aynı kayıt varsa uyarı versin ve kayıt yapmasın. Bu konuda yardımlarınızı bekliyorum.
 

Ekli dosyalar

Sayın ockucukay

Yetkili Girişi Makrosunun başına aşağıdaki kodlamayı ilave edin.
kodlama daha basitte olabilirdi ama 3 farklı kriter dikkate alındığı için döngü ile yaptım...

Kod: 
Set Syf1 = Sheets("Yetkili Giriş")
Set Syf2 = Sheets("YETKILI")
son2 = [YETKILI!b65536].End(3).Row

ad = Syf1.Range("B8").Value 'Ad
Soyad = Syf1.Range("B10").Value 'Soyad
Tel = Syf1.Range("E2").Value 'Tel

For i = 4 To son2
If ad = "" And Soyad = "" And Tel = "" Then GoTo Hata1
If ad = Syf2.Range("D" & i) And Soyad = Syf2.Range("E" & i) And Tel = Syf2.Range("H" & i) Then GoTo Hata2
Hata1:  MsgBox "Lütfen Adı Soyadı ve Telefon Bölümlerini doldurunuz."
Exit Sub
Hata2: MsgBox ad & " " & Soyad & " Ait Telefon Kaydı Daha Önce Yapılmış", vbInformation, "Kayıt Bulundu"
Exit Sub

Next i
 
turk-x' Alıntı:
Sayın ockucukay

Yetkili Girişi Makrosunun başına aşağıdaki kodlamayı ilave edin.
kodlama daha basitte olabilirdi ama 3 farklı kriter dikkate alındığı için döngü ile yaptım...

Kod: 
Set Syf1 = Sheets("Yetkili Giriş")
Set Syf2 = Sheets("YETKILI")
son2 = [YETKILI!b65536].End(3).Row

ad = Syf1.Range("B8").Value 'Ad
Soyad = Syf1.Range("B10").Value 'Soyad
Tel = Syf1.Range("E2").Value 'Tel

For i = 4 To son2
If ad = "" And Soyad = "" And Tel = "" Then GoTo Hata1
If ad = Syf2.Range("D" & i) And Soyad = Syf2.Range("E" & i) And Tel = Syf2.Range("H" & i) Then GoTo Hata2
Hata1:  MsgBox "Lütfen Adı Soyadı ve Telefon Bölümlerini doldurunuz."
Exit Sub
Hata2: MsgBox ad & " " & Soyad & " Ait Telefon Kaydı Daha Önce Yapılmış", vbInformation, "Kayıt Bulundu"
Exit Sub

Next i
Genişletmek için tıkla ...

hocam söylediğin gibi yaptım, ama yetkili giriş sayfasında veri olduğu halde "Lütfen Adı Soyadı ve Telefon Bölümlerini doldurunuz." deyip makroyu kapatıyor. Şimdi hiç kayıda izin vermiyor :( Ne yapmalıyım?
 
Selamlar,

Mükerrer kayıt için hangi kriterler geçerli olacak?
 
Selamlar,

Aşağıdaki kodu denermisiniz.

Kod: 
Option Explicit
 
Sub KAYDET()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim BUL As Range, ADRES As String, SAY As Byte, SATIR As Long
 
    Set S1 = Sheets("Yetkili Giriş")
    Set S2 = Sheets("YETKILI")
 
    If S1.Range("B8") <> "" And S1.Range("B10") <> "" Then
 
        Set BUL = S2.Range("D3:D65536").Find(S1.Range("B8"))
        If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
        If UCase(Replace(Replace(S2.Cells(BUL.Row, "E"), "i", "İ"), "ı", "I")) = UCase(Replace(Replace(S1.Range("B10"), "i", "İ"), "ı", "I")) Then SAY = SAY + 1
        Set BUL = S2.Range("D3:D65536").FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
        End If
 
        If SAY > 0 Then
            MsgBox "Bu isimde kayıt var, aynı isimle kayıt yapamazsınız !", vbCritical, "Dikkat !"
        Else
            SATIR = S2.Range("A65536").End(3).Row + 1
            S2.Cells(SATIR, "A").Value = WorksheetFunction.Max(S2.Range("A4:A65536")) + 1
            S2.Cells(SATIR, "B") = S1.Range("B4")
            S2.Cells(SATIR, "C") = S1.Range("B6")
            S2.Cells(SATIR, "D") = S1.Range("B8")
            S2.Cells(SATIR, "E") = S1.Range("B10")
            S2.Cells(SATIR, "G") = S1.Range("B12")
            S2.Cells(SATIR, "H") = S1.Range("E2")
            S2.Cells(SATIR, "I") = S1.Range("E4")
            S2.Cells(SATIR, "J") = S1.Range("E6")
            S2.Cells(SATIR, "K") = S1.Range("E8")
            S2.Cells(SATIR, "L") = S1.Range("E10")
            MsgBox "Kayıt işlemi tamamlanmıştır.", vbInformation
        End If
 
    Else
 
    MsgBox "Eksik bilgi girdiniz !" & vbCrLf & "Lütfen adı-soyadı bilgilerini giriniz.", vbExclamation, "Dikkat !"
 
    End If
 
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub
 
Korhan hocam, çok güzel çalışıyor. Çok teşekkür ediyorum ilginiz için, şimdi kodu incelemek istiyorum ki her seferinde başınızı ağrıtmayayım.
 
Selamlar,

Türkçe ve büyük-küçük harflerde sorun yaşamamanız için koda ekleme yaptım. Lütfen son halini kullanın.
 
Korhan Ayhan' Alıntı:
Selamlar,

Türkçe ve büyük-küçük harflerde sorun yaşamamanız için koda ekleme yaptım. Lütfen son halini kullanın.
Genişletmek için tıkla ...

İşte bu yaptığınıza yaptığı işe özen göstermek denir. Korhan bey, ilginize çok ama çok teşekkür ediyorum.Kodun son halini aldım.
 
korhan hocam

kodun son halini ancak deneyebildim. rastgele bir kayıt bile yapmaya çalışsam "böyle bir kayıt var, kayıt yapamazsın" mesajı geliyor ve kayıt yapmıyor. ne yapabilirim?
 

Ekli dosyalar

ockucukay' Alıntı:
korhan hocam

kodun son halini ancak deneyebildim. rastgele bir kayıt bile yapmaya çalışsam "böyle bir kayıt var, kayıt yapamazsın" mesajı geliyor ve kayıt yapmıyor. ne yapabilirim?
Genişletmek için tıkla ...

Hatırlatma, yardım edebilecek arkadaşım var mı acaba?
 
Dosyanız ekte.:cool:
Korhan beyin kodlarında kırmızı kodlarda değişiklik yaptım.:cool:
Kod: 
Sub YetkiliGiris()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim BUL As Range, ADRES As String, SAY As Byte, SATIR As Long
 
    Set S1 = Sheets("Yetkili Giriş")
    Set S2 = Sheets("YETKILI")
 
    If S1.Range("B8") <> "" And S1.Range("B10") <> "" Then
 
        Set BUL = S2.Range("[B][COLOR="Red"]D3:D65536[/COLOR][/B]").Find(S1.Range("B8").Value, , xlValues, xlWhole)
        If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
        If UCase(Replace(Replace(S2.Cells(BUL.Row, "E"), "i", "İ"), "ı", "I")) = UCase(Replace(Replace(S1.Range("B10"), "i", "İ"), "ı", "I")) Then SAY = SAY + 1
        Set BUL = S2.Range("[B][COLOR="Red"]D3:D65536[/COLOR][/B]").FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
        End If
 
        If SAY > 0 Then
            MsgBox "Bu isimde kayıt var, aynı isimle kayıt yapamazsınız !", vbCritical, "Dikkat !"
        Else
            SATIR = S2.Range("A65536").End(3).Row + 1
            S2.Cells(SATIR, "B") = S1.Range("B4")
            S2.Cells(SATIR, "C") = S1.Range("B6")
            S2.Cells(SATIR, "D") = S1.Range("B8")
            S2.Cells(SATIR, "E") = S1.Range("B10")
            S2.Cells(SATIR, "G") = S1.Range("B12")
            S2.Cells(SATIR, "H") = S1.Range("E2")
            S2.Cells(SATIR, "I") = S1.Range("E4")
            S2.Cells(SATIR, "J") = S1.Range("E6")
            S2.Cells(SATIR, "K") = S1.Range("E8")
            S2.Cells(SATIR, "L") = S1.Range("E10")
            MsgBox "Kayıt işlemi tamamlanmıştır.", vbInformation
        End If
 
    Else
 
    MsgBox "Eksik bilgi girdiniz !" & vbCrLf & "Lütfen adı-soyadı bilgilerini giriniz.", vbExclamation, "Dikkat !"
 
    End If
 
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub
 

Ekli dosyalar

şimdi farkettim, bu kodla sıra no veremiyorum. hep en son kaydın üstüne yapıyor. bir farklılık göremedim önceki kodla, sebebi ne olabilir acaba?
 
ockucukay' Alıntı:
şimdi farkettim, bu kodla sıra no veremiyorum. hep en son kaydın üstüne yapıyor. bir farklılık göremedim önceki kodla, sebebi ne olabilir acaba?
Genişletmek için tıkla ...
Nasıl bir farklılık yok.
Sizin sorunuz neydi.Girdiğiniz her isme bundan var deyip prosedürden çıkılmıyormuydu.Bu sorun çözülmedimi.Siz bu konudan daha önce (Alt satıra yazam konusu) bahsetmemiştiniz.Yoksa siz bahsettinizde benmi yapamadım.Anlayamıyorum.Nasıl ayni ,değişen bir şey yok diyorsunuz.
Ha arkadaş bende bu eksikte var onuda yaparmısınız deseniz,onuda elbette hallederiz.O konu başka.:cool:
 
Evren Gizlen' Alıntı:
Nasıl bir farklılık yok.
Sizin sorunuz neydi.Girdiğiniz her isme bundan var deyip prosedürden çıkılmıyormuydu.Bu sorun çözülmedimi.Siz bu konudan daha önce (Alt satıra yazam konusu) bahsetmemiştiniz.Yoksa siz bahsettinizde benmi yapamadım.Anlayamıyorum.Nasıl ayni ,değişen bir şey yok diyorsunuz.
Ha arkadaş bende bu eksikte var onuda yaparmısınız deseniz,onuda elbette hallederiz.O konu başka.:cool:
Genişletmek için tıkla ...

yok hocam farklılık yok derken sizin yaptığınız düzeltmeyi kastetmedim :). İfade hatası olmuş. sıra no veren kodlarda bir farklılık yok demek istemiştim. neyse hocam, sizi sıkmamak için bende üzerinde biraz çalıştım.aşağıda kod üzerinde yapmaya çalıştığım düzeltmeleri tırnak içine aldım. F8 ile ilerleyince çalışıyor. Ama yetkili giriş sayfasından çalıştırınca en alt satıra sıra no olarak 1 veriyor. bu konuda yardım ederseniz sevineceğim. ilginize çok teşekkür ederim.

SATIR = S2.Range("A65536").End(3).Row + 1
"enbuyuk = WorksheetFunction.Max(Range("a5:a65536"))" bu satırı ekledim.
"S1.Range("B2").Value = enbuyuk + 1" bu satırı ekledim.
"S2.Cells(SATIR, "A") = S1.Range("B2")"bu satırı ekledim.
S2.Cells(SATIR, "B") = S1.Range("B4")
S2.Cells(SATIR, "C") = S1.Range("B6")
S2.Cells(SATIR, "D") = S1.Range("B8")
S2.Cells(SATIR, "E") = S1.Range("B10")
S2.Cells(SATIR, "G") = S1.Range("B12")
S2.Cells(SATIR, "H") = S1.Range("E2")
S2.Cells(SATIR, "I") = S1.Range("E4")
S2.Cells(SATIR, "J") = S1.Range("E6")
S2.Cells(SATIR, "K") = S1.Range("E8")
S2.Cells(SATIR, "L") = S1.Range("E10")
 
Kırmızı satırı ilgili yere koyun.:cool:
Kod: 
SATIR = S2.Range("A65536").End(3).Row + 1
            [B][COLOR="Red"]S2.Cells(SATIR, "A").Value = WorksheetFunction.Max(S2.Range("A4:A65536")) + 1[/COLOR][/B]
            S2.Cells(SATIR, "B") = S1.Range("B4")
 
Evren Gizlen' Alıntı:
Kırmızı satırı ilgili yere koyun.:cool:
Kod: 
SATIR = S2.Range("A65536").End(3).Row + 1
            [B][COLOR="Red"]S2.Cells(SATIR, "A").Value = WorksheetFunction.Max(S2.Range("A4:A65536")) + 1[/COLOR][/B]
            S2.Cells(SATIR, "B") = S1.Range("B4")
Genişletmek için tıkla ...

yine aynı şeyi yapıyor, f8 ile ilerlediğimde sorun yok, ama diskete bastığımda sıra noyu 1 atıyor. anlamadım ben bu işten birşey?????
 
Selamlar,

#6 nolu mesajımdaki kodu güncelledim. Denermisiniz.

YETKILI isimli sayfadaki tüm satırları görünür yapın. (4. satır gizli)
Daha sonra 4. satır dahil tüm verileri silip makroyu tekrar çalıştırın.

Eğer hala olmuyor diyorsanız ekteki dosyayı inceleyin.
 

Ekli dosyalar

teşekkür ederim, hocam. 2-3 defa silip silip yaptım düzgün çalışıyor. Sayın Evren Gizlen'e ve size ilginizden dolayı çok teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst