Soru Evrak Kayıt Programı 2022

[yyhy]

Ekle Butonuna tıkladığım zaman Tahdit Kaldırılan sayfasına T.C. Kimlik Numarasından itibaren bilgileri en son boş satırdaki ilgili hücrelerine yapıştırabilmek için makro ne yazılabilir.
Yardımcı olabilecek arkadaşlara teşekkür ederim.

 

[AdemCan]

Merhaba,
Ekle kodu

Sub ekle()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sayfa2
Set s2 = Sayfa3 'Tahdit Kaldırılan Sayfası

sat = s2.Cells(Rows.Count, "C").End(3).Row
k = WorksheetFunction.CountIf(s2.Range("C3:C" & sat), s1.Range("AC17"))

If k = 0 Then
    s2.Cells(sat + 1, "C") = s1.Range("AC17")
    s2.Cells(sat + 1, "D") = s1.Range("AC19")
    s2.Cells(sat + 1, "E") = s1.Range("AC21")
    s2.Cells(sat + 1, "F") = s1.Range("AC23")
    s2.Cells(sat + 1, "G") = s1.Range("AH17")
    s2.Cells(sat + 1, "H") = s1.Range("AH19")
    s2.Cells(sat + 1, "I") = s1.Range("AH21")
    s2.Cells(sat + 1, "J") = CDate(s1.Range("AH23"))

Else
    MsgBox s1.Range("AC17") & " T.C. Kimlik Nolu kişi kayıtlı!", vbInformation, ""
End If
End Sub

Aynı kodlar ile Bul kodu örneği.

Sub bul()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sayfa2
Set s2 = Sayfa3 'Tahdit Kaldırılan Sayfası

sat = s2.Cells(Rows.Count, "C").End(3).Row
k = WorksheetFunction.CountIf(s2.Range("C3:C" & sat), s1.Range("AC17"))

If k > 0 Then
r = s2.Range("C3:C" & sat).Find(s1.Range("AC17")).Row
    s1.Range("AC17") = s2.Cells(r, "C")
    s1.Range("AC19") = s2.Cells(r, "D")
    s1.Range("AC21") = s2.Cells(r, "E")
    s1.Range("AC23") = s2.Cells(r, "F")
    s1.Range("AH17") = s2.Cells(r, "G")
    s1.Range("AH19") = s2.Cells(r, "H")
    s1.Range("AH21") = s2.Cells(r, "I")
    s1.Range("AH23") = CDate(s2.Cells(r, "J"))

Else
    MsgBox s1.Range("AC17") & " T.C. Kimlik Nolu kişi kaydı bulunamadı!", vbInformation, ""
End If

End Sub

 

[yyhy]

Sayın AdemCan ekle kodu çok güzel olmuş. Ama kişiyi mükerrer kayıt etmek istediğimizi sorsa evet hayıra göre kayıt yapsa çok güzel olacak. Aynı kişiye ait başka evraklarda gelmiş olabileceğinden uyarı vermesi güzel ama kayıtları da ona göre kaydetmek istiyor musunuz evet hayır uyarıya göre kaydetmesi daha iyi olacak.

Bul makrosunu denemedim. Onu da deneyip bilgi vereceğim.

 

[AdemCan]

O zaman mükerrer kontrolünü dosya numarasına göre yaptırmak uygun olacaktır. Evet - Hayır seçeneklerine de gerek kalmaz bu şekilde.
Kodu güncelleyip yeniden paylaşırım.

 

[AdemCan]

Sub ekle()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sayfa2
Set s2 = Sayfa3 'Tahdit Kaldırılan Sayfası

sat = s2.Cells(Rows.Count, "C").End(3).Row
k = WorksheetFunction.CountIf(s2.Range("H3:H" & sat), s1.Range("AH19"))

If k = 0 Then
    s2.Cells(sat + 1, "C") = s1.Range("AC17")
    s2.Cells(sat + 1, "D") = s1.Range("AC19")
    s2.Cells(sat + 1, "E") = s1.Range("AC21")
    s2.Cells(sat + 1, "F") = s1.Range("AC23")
    s2.Cells(sat + 1, "G") = s1.Range("AH17")
    s2.Cells(sat + 1, "H") = s1.Range("AH19")
    s2.Cells(sat + 1, "I") = s1.Range("AH21")
    s2.Cells(sat + 1, "J") = CDate(s1.Range("AH23"))

Else
    MsgBox s1.Range("AH19") & " numaralı dosya kayıtlı!", vbInformation, ""
End If
End Sub

Sub bul()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sayfa2
Set s2 = Sayfa3 'Tahdit Kaldırılan Sayfası

sat = s2.Cells(Rows.Count, "C").End(3).Row
k = WorksheetFunction.CountIf(s2.Range("H3:H" & sat), s1.Range("AH19"))

If k > 0 Then
r = s2.Range("H3:H" & sat).Find(s1.Range("AH19")).Row
    s1.Range("AC17") = s2.Cells(r, "C")
    s1.Range("AC19") = s2.Cells(r, "D")
    s1.Range("AC21") = s2.Cells(r, "E")
    s1.Range("AC23") = s2.Cells(r, "F")
    s1.Range("AH17") = s2.Cells(r, "G")
    s1.Range("AH19") = s2.Cells(r, "H")
    s1.Range("AH21") = s2.Cells(r, "I")
    s1.Range("AH23") = CDate(s2.Cells(r, "J"))

Else
    MsgBox s1.Range("AH19") & " numaralı dosya kaydı bulunamadı!", vbInformation, ""
End If

End Sub

 

[yyhy]

Deneyip bilgi vereyim. T.C. den dosya numasını gözandı ederek evet hayır yapılabilinir mi acaba?

 

[yyhy]

Denedim mükerrer kayıt da yapmak istiyorum. Evrak getiren kişi (T.C. li kişi ) 20 gün sonra tekrar bir evrak daha getirebilir. Dosya numaraları da bir önceki dosyanın numarasını aldığı oluyor. Uyarı versin kayıt yapmak istiyor musun istemiyor musun şeklinde evet - hayır ile onaylayıp kaydı yapalım veya yapmayalım olursa daha güzel olacaktır.

 

[AdemCan]

Dosya numaraları da tekrar ediyorsa, kayıt bulma işlemi için hangi veriyi kullanıyorsunuz?

 

[yyhy]

T.C. yi kullanıyorum bilgileri gelsin yeter ikinci üçüncü evraka manuel veri süzden bakıyorum.

 

[AdemCan]

Evet - Hayır seçeneklerine göre mükerrer kayıt yapan kodlar.

Sub ekle()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sayfa2
Set s2 = Sayfa3 'Tahdit Kaldırılan Sayfası

sat = s2.Cells(Rows.Count, "C").End(3).Row + 1
tcno = s1.Range("AC17")
k = WorksheetFunction.CountIf(s2.Range("C3:C" & sat), tcno)

If k = 0 Then
    GoTo kayit
ElseIf k > 0 Then
soru = MsgBox(tcno & " T.C. Kimlik Numaralı kişi kayıtlı! Yeni kayıt oluşturmak istiyor musunuz?", vbQuestion + vbYesNo, "")
    If soru = vbYes Then
kayit:
        s2.Cells(sat, "C") = s1.Range("AC17")
        s2.Cells(sat, "D") = s1.Range("AC19")
        s2.Cells(sat, "E") = s1.Range("AC21")
        s2.Cells(sat, "F") = s1.Range("AC23")
        s2.Cells(sat, "G") = s1.Range("AH17")
        s2.Cells(sat, "H") = s1.Range("AH19")
        s2.Cells(sat, "I") = s1.Range("AH21")
        s2.Cells(sat, "J") = CDate(s1.Range("AH23"))
    Else
        MsgBox "Kayıt işlemi iptal edildi!", vbInformation, ""
    End If
Else
    MsgBox tcno & " T.C. Kimlik Numaralı kişi kayıt edildi!", vbInformation, ""
End If
End Sub

Bul kodları için de #2 nolu mesajdaki kodları kullanabilirsiniz.

 

[yyhy]

Sayın @AdemCan teşekkür ederim. Güzel olmuş emeğinize sağlık ihtiyaca cevap verdi.

 

[AdemCan]

Rica ederim. Bul seçeneği için de bir alternatif hazırladım.
Birden fazla kayıt olunca manuel filtre yöntemi kullanmadan arama yapabilirsiniz.

 

[yyhy]

Sayın @AdemCan emeğinize sağlık mesajı yeni gördüm. İnceleyeceğim.
Sayın @AdemCan T.C. nin üzerine koyduğunuz butonu tam anlayamadım. Kayıt Etme olayı güzel olmuş.

 

[AdemCan]

Sayın @yyhy rica ederim.

T.C. Kimlik No bilgisinin üzerindeki nesne Combobox.
Mükerrer kayıtları arama işlemi için.

Eklediğim dosyada 12345678915 kimlik numarasına ait 3 kayıt var.

T.C. Kimlik Numarasını yazıp Bul & Getir yazan butona tıklatınız zaman mükerrer kayıtlar için resimdeki açıklama çıkar.

Spoyler: Açıklama Resmi

Tamam butonu ile açıklamayı kapattığınız zaman da Combobox içerisinde mükerrer kayıtların sıra numaraları sıralanır.

Spoyler: Sıra Numarası

Listelenen sıra numaralarına tıklayarak kayıtları tabloya alabilirsiniz.

 

[yyhy]

Sayın @AdemCan son şekliyle çok güzel olmuş. İhtiyaca ziyadesiyle cevap verdi. Emeğinize sağlık.