• DİKKAT

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

Birincil Veritabnaında Aranan Kayıt bulunamazsa İkincil veritabanına bak,

H

hsayar

Katılım
2 Mart 2005
Mesajlar
2,960
Excel Vers. ve Dili
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
Herkese kolay gelsin, bir sorum var en az kodla nasıl üstesinden gelebiliriz?
Şöyle ki Aranan Tcno Birincil Veritabanında bulunamazsa İkincil veritabanına bak, ikincilde bulunamazsa, üçüncüye bak gibi.....



Private Sub Worksheet_Change(ByVal Target As Range)
Call DegiskenTani

If Intersect(Target, [C2]) Is Nothing Then Exit Sub 'a4:a65536 aralığı değişmemişse çık
If Target.Count > 1 Then Exit Sub 'birden fazla satır seçildiğinde

'*****************************************************************
'Ripek - 26/12/2007
'veri tabanına bağlan
Baglan:
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 FSO As Object 'Dosya kontol objesi tanımla
Dim SQLStr, Kaynak, tcno As String 'Sorgulanacak alanlar, kaynak dosya, ve sorgulanacak kritere ilişkin tanımları yap
'***********************************************************************
currentrow = Target.Row '?
CurrentvALUE = Target.Value '?

Kaynak = "C:\VT\VT1.xls" 'Kaynak olarak bu kitabın olduğu klasörde veri tabanı belirt
If Dir(Kaynak) = "" Then
MsgBox Kaynak & " " & Chr(10) & " Dosyası Bulunamadı.", vbInformation, "Bilgi"
Exit Sub
End If


tcno = Target.Value 'Sorgulanacak değeri ata
'Sorgulanacak başlıkları ve sorgulanacak kriteri yaz
basliklar = "TCKİMLİKNO, 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, "
basliklar = basliklar & "CEK1_ILCE, CEK1_KOY, CEK1_MEVK, CEK1_ADA, CEK1_PRS, CEK1_MIKT"


sayfaadi = "[data$] "
sorgu = "TCKİMLİKNO = " & tcno
SQLStr = "SELECT " & basliklar & " FROM " & sayfaadi & " WHERE " & sorgu

Set Baglanti = CreateObject("ADODB.Connection") 'bağlantıyı kur
With Baglanti
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Extended Properties").Value = "Excel 8.0"
.Properties("Data Source").Value = Kaynak
.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
'***********************************************************************

If Kayit1.RecordCount = 1 Then '1 adet kayıt bulundu ise
Cells(3, "D").Value = Kayit1("ADI") 'bulunanları yaz
Cells(4, "D").Value = Kayit1("SOYADI") '.. ""...
Cells(5, "D").Value = Kayit1("BABAADI") '.. ""...
Cells(6, "D").Value = Kayit1("ANNEADI") '.. ""...
Cells(7, "D").Value = Kayit1("DOGUMYERİ") '.. ""...
Cells(8, "D").Value = Kayit1("DOGUMTARİHİ") '.. ""...
Cells(9, "D").Value = Kayit1("ADR_MUHTAR") '.. ""...
Cells(10, "D").Value = Kayit1("ADR_ILCE") & "/" & Kayit1("ADR_IL") '.. ""...
Cells(13, "E").Value = Kayit1("CEK1_ILCE")
Cells(14, "E").Value = Kayit1("CEK1_KOY")
Cells(15, "E").Value = Kayit1("CEK1_MEVK")
Cells(16, "E").Value = Kayit1("CEK1_ADA") & " Ada/" & Kayit1("CEK1_PRS") & " Prs." '.. ""...
Cells(17, "E").Value = Kayit1("CEK1_MIKT")
'Cells(3, "AL").Value = Kayit1("NFS_MHKY")

Range("D14").Select 'h sütununu seç
Else
MsgBox "Aradığınız Kayıt Bulunamadı.", vbInformation, "Bilgi" 'uyarı ver
tckno = CurrentvALUE
UserForm1.Show 'kayıt eklemek için user forma geç
End If
Else 'bağlantıda hata varsa
son:
MsgBox "Bağlantı Hatası.Kontrol Ediniz", vbInformation, "Bilgi" 'uayrı ver
End If

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
Set FSO = Nothing 'değişkeni hafızadan sil
End Sub
Genişletmek için tıkla ...
 
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
  If Intersect(Target, [C2]) Is Nothing Then Exit Sub                                 '‡a4:a65536 aralığı değişmemişse çık
  If Target.Count > 1 Then Exit Sub                                                   '‡birden fazla satır seçildiğinde
            
Baglan:
  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 KllStr, KllDgr                                                                  'Kullanılan satır ve Deger
  
'›››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››››
  KllStr = Target.Row
  KllDgr = Target.Value
  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, 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 = " & KllDgr
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
 '***********************************************************************

        If Kayit1.RecordCount = 1 Then                      '1 adet kayıt bulundu ise
          Cells(3, "D").Value = Kayit1("ADI")          'bulunanları yaz
          Cells(4, "D").Value = Kayit1("SOYADI")       '..   ""...
          Cells(5, "D").Value = Kayit1("BABAADI")      '..   ""...
          Cells(6, "D").Value = Kayit1("ANNEADI")      '..   ""...
          Cells(7, "D").Value = Kayit1("DOGUMYERİ")    '..   ""...
          Cells(8, "D").Value = Kayit1("DOGUMTARİHİ")  '..   ""...
          Cells(9, "D").Value = Kayit1("ADR_MUHTAR")  '..   ""...
          Cells(10, "D").Value = Kayit1("ADR_ILCE") & "/" & Kayit1("ADR_IL")   '..   ""...
        Else
            If intKayNo <= 3 Then
              intKayNo = intKayNo + 1
              GoTo KaynakSec
            Else
              MsgBox "Aradığınız Kayıt Bulunamadı.", vbInformation, "Bilgi"       'uyarı ver
              tckno = KllDgr
              UserForm1.Show                                                      'kayıt eklemek için user forma geç
            End If
        End If
    Else                                                        'bağlantıda hata varsa
son:
    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
Set FSO = Nothing       'değişkeni hafızadan sil
End Sub
'Hs®yaz
hallettim şimdilik sorun yok ama ustalar göz atarsa sevinirim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst