- Katılım
- 2 Mart 2005
- Mesajlar
- 2,960
- Excel Vers. ve Dili
- ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
Kod:
[Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [c2:c2000]) Is Nothing Then Exit Sub 'Kimlik Numarasının Gireleceği erim/hücre
If Target.Count > 1 Then Exit Sub
VatNo = Target.Value
If VatNo = "" Then Exit Sub
HdfSatNo = Target.Row
Call sbNFSKYTAL '(Target.Value)
If boolIPTAL = True Then Exit Sub
End Sub
Private Sub sbNFSKYTAL() '(tcno)
boolIPTAL = False
'If Cells(HdfSatNo, "L") <> "" Then
' MsgBox "Nüfusa Kayıtlı Olduğu Mah/köy" & Cells(HdfSatNo, "L") & vbNewLine & _
' " olarak girilmiştir, devam ederseniz bu alan silinebilir!" & vbNewLine & _
' " devam etmek istiyor musunuz?", vbYesNo, "SİLENECEK ALAN"
' If vbNo Then Exit Sub
'Else
'End If
'NUFUS KAYITLARINI AL
Dim Baglanti As ADODB.Connection 'ADODB bağlantı değişkeni tanımla
Dim Kayit1 As ADODB.Recordset 'ADODB kayıt alan değişkeni tanımla
Dim intKayNo As Integer 'Kaynak Dosya Numarası
Dim SQLStr As String 'Sorgulanacak alanlar
Dim strADI$, strCINS$, strSYD$, strBAD$, strAAD$
Dim strDYR$, dteDTR As Date
Dim strNILI$, strNILC$, strNMKY$
Dim strAILI$, strAILC$, strABLD$, strAMKY$, strCSK$
Dim strKNO$, strDNO$, strKDNO$
'›››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››
intKayNo = 1
KaynakSec:
Select Case intKayNo
'Kaynak olarak bu kitabın olduğu klasörde veri tabanı belirt
Case Is = 1: strVTTCK = "C:\VT\vttc2009.xls"
Case Is = 2: strVTTCK = "C:\VT\vttc2007.xls"
Case Is = 3: strVTTCK = "C:\VT\vttcEKLR.xls"
End Select
'\ Seçilen kaynak mevcut mu?
If Dir(strVTTCK) = "" Then
MsgBox strVTTCK & " " & Chr(10) & " Dosyası Bulunamadı.", vbInformation, "Bilgi"
Exit Sub
End If
'Sorgulanacak başlıkları ve sorgulanacak kriteri yaz
basliklar = "TCKİMLİKNO, C, ADI, SOYADI, ANNEADI, BABAADI, DOGUMYERİ, DOGUMTARİHİ, "
basliklar = basliklar & "NFS_MHKY, NFS_ILCE, NFS_IL, "
basliklar = basliklar & "ADR_MUHTAR, ADR_ILCE, ADR_IL, ADR_CD_SKK, ADR_KNO, ADR_DNO"
sayfaadi = "[data$] "
sorgu = "TCKİMLİKNO = " & VatNo
SQLStr = "SELECT " & basliklar & " FROM " & sayfaadi & " WHERE " & sorgu
'\ Bağlantıyı Kur
Set Baglanti = CreateObject("ADODB.Connection")
With Baglanti
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Extended Properties").Value = "Excel 8.0"
.Properties("Data Source").Value = strVTTCK
.CursorLocation = adUseServer
.Mode = adModeReadWrite
.Open
End With
If Err = 0 Then 'eğer bağlantıda hata yoksa
Set Kayit1 = CreateObject("ADODB.Recordset") 'kayıt bağlantısını kur
With Kayit1
.ActiveConnection = Baglanti
.CursorLocation = adUseServer
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Source = SQLStr
.Open
End With
'***********************************************************************
bassut = 4
If Kayit1.RecordCount = 1 Then '1 adet kayıt bulundu ise
'Kimlik Bilgileri
'strCINS
If Kayit1("C") <> "" Then strCINS = Kayit1("C")
If Kayit1("ADI") <> "" Then strADI = Kayit1("ADI")
If Kayit1("SOYADI") <> "" Then strSYD = Kayit1("SOYADI")
If Kayit1("BABAADI") <> "" Then strBAD = Kayit1("BABAADI")
If Kayit1("ANNEADI") <> "" Then strAAD = Kayit1("ANNEADI")
If Kayit1("DOGUMYERİ") <> "" Then strDYR = Kayit1("DOGUMYERİ")
If Kayit1("DOGUMTARİHİ") <> "" Then dteDTR = Format(Kayit1("DOGUMTARİHİ"), "DD/MM/YYYY")
'Nüfusa Kayıtlı Olduğu
If Kayit1("NFS_IL") <> "" Then strNILI = Kayit1("NFS_IL")
If Kayit1("NFS_ILCE") <> "" Then strNILC = Kayit1("NFS_ILCE")
If Kayit1("NFS_MHKY") <> "" Then strNMKY = Kayit1("NFS_MHKY")
'Adres Bilgileri
If Kayit1("ADR_IL") <> "" Then strAILI = Kayit1("ADR_IL")
If Kayit1("ADR_ILCE") <> "" Then strAILC = Kayit1("ADR_ILCE")
If Kayit1("ADR_MUHTAR") <> "" Then strAMKY = Kayit1("ADR_MUHTAR")
If Kayit1("ADR_CD_SKK") <> "" Then strCSK = Kayit1("ADR_CD_SKK")
If Kayit1("ADR_KNO") <> "" Then strKNO = Kayit1("ADR_KNO")
If Kayit1("ADR_DNO") <> "" Then strDNO = Kayit1("ADR_DNO")
If strDNO = "" Then
strKDNO = Format(strKNO, "@")
Else
strKDNO = Format(strKNO & "/" & strDNO, "@")
End If
Cells(HdfSatNo, bassut + 0).Value = hsr.FncIlkHarflerBuyuk(strCINS)
bassut = bassut + 1
Cells(HdfSatNo, bassut + 0).Value = hsr.FncIlkHarflerBuyuk(strADI)
Cells(HdfSatNo, bassut + 1).Value = hsr.UCaseTr(strSYD)
Cells(HdfSatNo, bassut + 2).Value = hsr.FncIlkHarflerBuyuk(strBAD)
Cells(HdfSatNo, bassut + 3).Value = hsr.FncIlkHarflerBuyuk(strAAD)
Cells(HdfSatNo, bassut + 4).Value = hsr.FncIlkHarflerBuyuk(strDYR)
Cells(HdfSatNo, bassut + 5).Value = dteDTR
Cells(HdfSatNo, bassut + 6).Value = hsr.FncIlkHarflerBuyuk(strNILI)
Cells(HdfSatNo, bassut + 7).Value = hsr.FncIlkHarflerBuyuk(strNILC)
Cells(HdfSatNo, bassut + 8).Value = hsr.FncIlkHarflerBuyuk(strNMKY)
Cells(HdfSatNo, bassut + 9).Value = hsr.FncIlkHarflerBuyuk(strAILI)
Cells(HdfSatNo, bassut + 10).Value = hsr.FncIlkHarflerBuyuk(strAILC)
Cells(HdfSatNo, bassut + 11).Value = hsr.FncIlkHarflerBuyuk(strABLD)
Cells(HdfSatNo, bassut + 12).Value = hsr.FncIlkHarflerBuyuk(strAMKY)
Cells(HdfSatNo, bassut + 13).Value = hsr.FncIlkHarflerBuyuk(strCSK)
Cells(HdfSatNo, bassut + 14).Value = strKDNO
Else
If intKayNo <= 3 Then
intKayNo = intKayNo + 1
GoTo KaynakSec
Else
MsgBox "Aradığınız NÜFUS KAYDI Bulunamadı.", vbInformation, "Bilgi" 'uyarı ver
boolIPTAL = True
[B][COLOR=Red] 'formKIMLIKGIRIS.Show 'kayıt eklemek için user forma geç[/COLOR][/B]
End If
End If
Else 'bağlantıda hata varsa
sonNFS:
MsgBox "Bağlantı Hatası.Kontrol Ediniz", vbInformation, "Bilgi" 'uayrı ver
End If
'\ Bağlantıyı kapat
If CBool(Kayit1.State And adStateOpen) = True Then Kayit1.Close '?
Set Kayit1 = Nothing 'değişkeni hafızadan sil
If CBool(Baglanti.State And adStateOpen) = True Then Baglanti.Close '?
Set Baglanti = Nothing 'değişkeni hafızadan sil
End Sub2) hsr.xla üzerindeki userform aracılığı c:\vt\kmlk.accdb üzerinde bağlı tcno varsa değişiklik onayı isteyerek değişiklik yapan, yoksa veri girişi yapan kodlar nasıl olmalıdır. mdb dosyalarında en fazla kayıt sınırı nedir
Son düzenleme: