bilgileri kayıt yapıp, tekrar alma

[oRjiN@L]

arkadaşlar ekte gönderdiğim çalışmada ki anasayfayı doldurup;
1-kayıt ekle butonunua tıkladığımda anasayfaya girdiğim bilgileri kayıt sayfasına kayıdetmek.
2-kayıt yaptığım bilgileri kime ait ise 6. satırda ki tam adı soyadın, yan bölümdeki "geçmiş kayıtlar" bölümüne kaydederek listelemek.
3-listeyi:en son yapılan kaydı 1.sıraya almak ve daha önceki yapmış olduğumuz şahıs kayıtlarını bir "geçmiş kayıtlar" listesinden aşağıya kaydırarak 2.3.4.5.......kayıtlara almak, yani son kayıt 1.sırada olacak öncekiler aşağıya sıralanacak
4-yaptığımız kayıtları "geçmiş kayıtlar" listesinden ismin üzerine tıkladığımızda anasayfamıza tekrar olduğu gibi getirmek, butonda olur ama isim olursa daha kullanılışlı olur.
*kayıtlarda kayma veya değişme olmaması gerek çünkü 23 adet (şimdilik)belge anasayfadaki bilgiler doğrultusunda doluyor*
5-kayıt yapıldığında "kayıt yapıldı" msg.box.uyarısı
6-tc numarası kayıtlı ise "tc numarası kayıtlı" msg.box.uyarısı

şeklinde hazırlamak istiyorum ama bir türlü yapamadım makro yazmayı bilmiyorum. bana yardım ederseniz sevinirim.

*doğrulamalar AS ve AT sütununda gizli*

 

[Necdet]

Merhaba,

Pazar günü öğleden sonramı aldı ama umarım işinize yarar.

Dosyayı oldukça sadeleştirdim.

Aşağıdaki kodlar, Ana Sayfa'nın kod bölümünde olmalı.

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Kol As Integer, i As Integer
Dim sv As Worksheet
Set sv = Sheets("Veri")
On Error GoTo Son
If Intersect(Target, [H:I]) Is Nothing Then Exit Sub
If Target.Row = 1 Then Exit Sub
For Kol = 2 To 43
    If Kol <> 5 Then
        Cells(Kol, "D") = sv.Cells(Target.Row, Kol)
    End If
Next Kol
i = 44
For Kol = 48 To 58
    Cells(i, "D") = sv.Cells(Target.Row, Kol)
    i = i + 1
Next Kol
Range("F40") = sv.Cells(Target.Row, "AR")
Range("F41") = sv.Cells(Target.Row, "AS")
Range("F42") = sv.Cells(Target.Row, "AT")
Range("F43") = sv.Cells(Target.Row, "AU")
Son:
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Son
If Intersect(Target, [D2]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
If TCKimlikOnYazimKontrol(Target.Value) = False Then
    MsgBox "Hatalı T.C. Kimlik Numarası Girdiniz"
    Target.Select
End If
Son:
End Sub

Aşağıdaki kodlar da bir modülde olmalı

Option Explicit
Sub Kaydet()
Dim sa As Worksheet, sv As Worksheet
Dim i As Long
Dim Kol As Integer
Set sa = Sheets("Ana Sayfa")
Set sv = Sheets("Veri")
sa.Select
If Application.WorksheetFunction.CountA([D2:D9]) < 7 Then
    MsgBox "Biraz Birşeyler Yazında Öyle Kaydedin"
    Exit Sub
End If
sv.Rows("2:2").Insert
sv.Range("A2").RowHeight = 15.75
Application.ScreenUpdating = False
Kol = 1
For i = 2 To 58
    Kol = Kol + 1
    If i = 44 Then Kol = Kol + 4
    sv.Cells(2, Kol) = sa.Cells(i, "D")
Next i
sv.Range("AR2") = sa.Range("F40")
sv.Range("AS2") = sa.Range("F41")
sv.Range("AT2") = sa.Range("F42")
sv.Range("AU2") = sa.Range("F43")
sv.Range("A2") = 1
sv.Range("A2:A" & sv.[B65536].End(3).Row).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
    Step:=1, Trend:=False
i = sa.[I65536].End(3).Row
If i < 3 Then i = 3
sa.Range("I3:I" & i).ClearContents
For i = 2 To sv.Range("A65536").End(3).Row
    sa.Cells(i, "I") = sv.Cells(i, "E")
Next i
MsgBox "Aktarım Yapılmıştır...", vbOKOnly, "[URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
Application.ScreenUpdating = True
End Sub

Sub Temizle()
Dim sa As Worksheet
Dim Evet As Variant
Set sa = Sheets("Ana Sayfa")
sa.Select
Evet = MsgBox("Silmek İstediğinizden Emin Misiniz?", vbYesNo)
If Evet = vbYes Then
    Range("D2:F4,D6:F39,D40:D43,F40:F43,D44:F58").ClearContents
Else
    MsgBox "Silmekten Vaz Geçtiniz..."
End If
End Sub

Function TCKimlikOnYazimKontrol(tcid) As Boolean
Dim d(1 To 11) As Integer
Dim n As Integer, Top1 As Integer, Top2 As Integer, cd1 As Integer, cd2 As Integer
If Len(tcid) <> 11 Or Not IsNumeric(tcid) Then
    TCKimlikOnYazimKontrol = False
    Else
    For n = 1 To 11
        d(n) = Mid(tcid, n, 1)
    Next
    Top1 = d(1) + d(3) + d(5) + d(7) + d(9)
    Top2 = d(2) + d(4) + d(6) + d(8)
 
    cd1 = (10 - (((3 * Top1) + Top2) Mod 10)) Mod 10
    cd2 = (10 - (((3 * (Top2 + cd1)) + Top1) Mod 10)) Mod 10
    If cd1 = d(10) And cd2 = d(11) Then
        TCKimlikOnYazimKontrol = True
        Else
        TCKimlikOnYazimKontrol = False
    End If
End If
End Function

H ve I sütununda Herhangi Bir Hücreye Çift Tıklandığında O Kişinin Bilgileri Getirilir.

Yeni Kayıt Girileceği Zaman Eski Bilgileri Silmek İçin Sil Butonunu Kullanabilirsiniz.

T.C. Kimlik Numarasının Doğru Yazımını Sağlamak İçin Sayıın Veysel Emre'nin sitemizde yayınlanan Kodlar Kullanılmıştır.

 

[oRjiN@L]

Allah senden razı olsun tam istediğim gibi olmuş,
ama ÇOK zamanının almışım kardeş helal et.
Sorun yaşarsam yazarım tekrar

çok teşekkür ederim.eline sağlık..

 

[Necdet]

Güle güle kullanınız.