C.xls A Sütunundaki tcnoyu V.xls de arayıp C.xlsdeki sütunlara ekle

hsayar · 28 Aralık 2007

ÇiftçiBilgiSistemi.xls (C) A4 ten itibaren girilen tckimlik nolarını Tckimlik.xls (V) kimlik sayfası A sütununda sorgulayacak ve bulduğu satırdaki istenilen verileri
1) (ADI SOYADI BABAADI ANA ADI DOĞUM YERİ DOĞUM TARİHİ) bu sayfadaki ilgili sütunlara yazacak.
2) Eğer veritabanında tc kimliknosu yoksa(ADI SOYADI BABAADI ANA ADI DOĞUM YERİ DOĞUM TARİHİ) verilerini ekleyecek(Buradaki veriler zorunlu, Tckimlik.xlsde verilmiş diğer sütun başlıkları isteğe bağlı)
Konuyu daha evvel bitmiş bir konunun altına açıtım şimdide pişman oldum dosya ektedir.
http://www.excel.web.tr/attachment.php?attachmentid=30599&d=1198833356

istediğim burada sn. ripekin bitirmiş olduğu projeye benzer bir şeydir
http://www.excel.web.tr/showthread.php?p=229064&posted=1#post229064

hsayar · 28 Aralık 2007

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    'On Error Resume Next
    'g s&#252;tunu: Vergi No
    '&#305;:j s&#252;tunu: belege trh/no
    If Intersect(Target, [A4:A65536]) Is Nothing Then Exit Sub
    If IsEmpty(Target) Or InStr(1, Target.Address, ":") <> 0 Then
        Cells(Target.Row, "B").ClearContents
        Cells(Target.Row, "C").ClearContents
        Cells(Target.Row, "D").ClearContents
        Cells(Target.Row, "E").ClearContents
        Cells(Target.Row, "F").ClearContents
        Cells(Target.Row, "G").ClearContents
        Exit Sub
    End If
    
    If Cells(Target.Row, "A") <> "" Then
    SAY = WorksheetFunction.CountIf(Columns(Target.Column), Target)
    If SAY > 1 Then
    Set BUL = Columns(Target.Column).Find(Target)
    If Not BUL Is Nothing Then
    ADRES = BUL.Address
    Do
    If Cells(Target.Row, "A") = Cells(BUL.Row, "A") Then
    SATIR = IIf(SATIR = "", BUL.Row & Space(1), SATIR & ", " & BUL.Row & Space(1))
    End If
    Set BUL = Columns(Target.Column).FindNext(BUL)
    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    GoTo UYARI
    End If: End If: End If
    GoTo Baglan
UYARI:     ONAY = MsgBox("Bu kay&#305;t daha &#246;nce a&#351;a&#287;&#305;daki sat&#305;rlarda girilmi&#351;tir !" & Chr(10) & Chr(10) & SATIR & Chr(10) & Chr(10) & "&#304;&#351;leme devam etmek istiyor musunuz?", vbYesNo + vbCritical, "D&#304;KKAT !")
    If ONAY = vbNo Then
        Cells(Target.Row, "A").ClearContents
        Cells(Target.Row, "B").ClearContents
        Cells(Target.Row, "C").ClearContents
        Cells(Target.Row, "D").ClearContents
        Cells(Target.Row, "E").ClearContents
        Cells(Target.Row, "F").ClearContents
        Cells(Target.Row, "G").ClearContents
        Target.Select
    Exit Sub: End If
    
    '*****************************************************************
'Ripek - 26/12/2007
Baglan:
MsgBox "BEKLEMEDE"
If Intersect(Target, [A4:A65536]) Is Nothing Then Exit Sub
Dim Baglanti As ADODB.Connection
Dim Kayit1 As ADODB.Recordset
Dim FSO As Object
Dim SQLStr, Kaynak, tcno As String
'***********************************************************************
CurrentRow = Target.Row
CurrentValue = Target.Value

Kaynak = Application.ThisWorkbook.Path & "\" & "Tckimlik.xls"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(Kaynak) = False Then
MsgBox Kaynak & " " & " Dosyas&#305; Bulunamad&#305;.", vbInformation, "Bilgi"
Exit Sub
End If

tcno = Target.Value
'SQLStr = "SELECT M&#220;KELLEFADISOYADI,VDA&#304;RES&#304;,VERG&#304;NO,ADRES&#304; FROM [data$] WHERE VERG&#304;NO=" & verginosu
SQLStr = "SELECT TCKIMLIKNO,ADI,SOYADI,ILK_SOYADI,ANA_ADI,BABA_ADI,C,DGM_YERI,DGM_TRH,NFS_IL,NFS_ILCE,ADR_IL,ADR_ILCE,ADR_MUHTAR,ADR_CD_SKK,ADR_KNO,ADR_DNO,SCM_NO,AD_SYD FROM [data$] WHERE TCKIMLIKNO=" & tcno
'(veritaban&#305;.xls)> M&#220;KELLEFADISOYADI   VDA&#304;RES&#304;    VERG&#304;NO ADRES&#304;
'(tckimlik.xls)> TCKIMLIKNO  ADI SOYADI  ILK_SOYADI  ANA_ADI BABA_ADI    C   DGM_YERI    DGM_TRH NFS_IL  NFS_ILCE    ADR_IL  ADR_ILCE    ADR_MUHTAR  ADR_CD_SKK  ADR_KNO ADR_DNO SCM_NO  AD_SYD
'                   A        B   C       D           E       F           G   H           I       J       K           L       M           N           O            P         Q       R       S
'                   1        2   3       4           5       6           7   8           9       10      11          12      13          14          15           16        17      18      19

Set Baglanti = CreateObject("ADODB.Connection")
    With Baglanti
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Properties("Extended Properties").Value = "Excel 8.0"
        .Properties("Data Source").Value = Kaynak
        .CursorLocation = adUseServer
        .Mode = adModeReadWrite
    [color=rED]    .Open [/COLOR]
    End With

    If Err = 0 Then
    Set Kayit1 = CreateObject("ADODB.Recordset")
    With Kayit1
        .ActiveConnection = Baglanti
        .CursorLocation = adUseServer
        .CursorType = adOpenKeyset
        .LockType = adLockOptimistic
        .Source = SQLStr
        .Open
    End With
 '***********************************************************************

    If Kayit1.RecordCount = 1 Then
          Cells(CurrentRow, "B").Value = Kayit1("ADI")
          Cells(CurrentRow, "C").Value = Kayit1("SOYADI")
          Cells(CurrentRow, "D").Value = Kayit1("BABA_ADI")
          Cells(CurrentRow, "E").Value = Kayit1("ANA_ADI")
          Cells(CurrentRow, "F").Value = Kayit1("DGM_YERI")
          Cells(CurrentRow, "G").Value = Kayit1("DGM_TRH")
    Else
        MsgBox "Arad&#305;&#287;&#305;n&#305;z Kay&#305;t Bulunamad&#305;.", vbInformation, "Bilgi"
        UserForm1.Show
    End If
Else
Son:
    MsgBox "Ba&#287;lant&#305; Hatas&#305;.Kontrol Ediniz", vbInformation, "Bilgi"
End If

If CBool(Kayit1.State And adStateOpen) = True Then Kayit1.Close
Set Kayit1 = Nothing
If CBool(Baglanti.State And adStateOpen) = True Then Baglanti.Close
Set Baglanti = Nothing
Set FSO = Nothing
Target.Offset(1, 0).Select
End Sub

şeklinde denetim ama data$ geçerli bir ad değil hatası veriyor [-2147467259(80004005)]

Recep İpek · 28 Aralık 2007

Veritabanında verilerin bulunduğu sayfanın ismi data olması gerekiyor.

Ayrıca bu sayfadaki başlıklar ile SQLStr değişkenine yazdığınız başlıkların aynı olması lazım.

Sayfalardaki başlıklar arasında boşluk vb bilgililer bulunması sakınca yaratabilir.

Örneğin ADI SOYADI, gibi.

Başka bir hata yok gibi görünüyor.

hsayar · 28 Aralık 2007

hocam muhasebeci eserin son örneğindeki veritabnaı sayfasını değiştirerek kullandım ama burada

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    'On Error Resume Next
'Application.EnableEvents = False
If Intersect(Target, [A4:A65536]) Is Nothing Then Exit Sub
    If IsEmpty(Target) Then
        Range("B" & Target.Row & ":AB" & Target.Row).Select
        Selection.ClearContents
        Target.Select
        Exit Sub
    End If

'    If Cells(Target.Row, "A") <> "" Then
'        SAY = WorksheetFunction.CountIf(Columns(Target.Column), Target)
'            If SAY > 1 Then
'                Set BUL = Columns(Target.Column).Find(Target)
'                    If Not BUL Is Nothing Then
'                        ADRES = BUL.Address
'                            Do
'                                If Cells(Target.Row, "A") = Cells(BUL.Row, "A") Then
'                                    SATIR = IIf(SATIR = "", BUL.Row & Space(1), SATIR & ", " & BUL.Row & Space(1))
'                                End If
'                            Set BUL = Columns(Target.Column).FindNext(BUL)
'                            Loop While Not BUL Is Nothing And BUL.Address <> ADRES
'        GoTo UYARI
'    End If: End If: End If
'    'GoTo Baglan
'UYARI:     ONAY = MsgBox("Bu kay&#305;t daha &#246;nce a&#351;a&#287;&#305;daki sat&#305;rlarda girilmi&#351;tir !" & Chr(10) & Chr(10) & SATIR & Chr(10) & Chr(10) & "&#304;&#351;leme devam etmek istiyor musunuz?", vbYesNo + vbCritical, "D&#304;KKAT !")
'    If ONAY = vbNo Then
'        Range("A" & Target.Row & ":AB" & Target.Row).Select
'        Selection.ClearContents
'        Target.Select
'        Exit Sub
'    Exit Sub: End If


Dim Baglanti As ADODB.Connection
Dim Kayit1 As ADODB.Recordset
Dim FSO As Object
Dim SQLStr, Kaynak1, Kaynak2, Kaynak3, verginosu As String
'***********************************************************************
CurrentRow = Target.Row
CurrentValue = Target.Value

Kaynak1 = "D:\Belgelerim\Ornek\Program_Data\veritabani.xls"
Kaynak2 = "D:\Belgelerim\Ornek\Program_Data\veritabani.xls"

Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(Kaynak1) = True Then
Kaynak3 = Kaynak1
ElseIf FSO.FileExists(Kaynak2) = True Then
Kaynak3 = Kaynak2
Else
MsgBox "Veritabani.xls Dosyas&#305; Bulunamad&#305;.", vbInformation, "Bilgi"
Exit Sub
End If
verginosu = CurrentValue
'

SQLStr = "SELECT TCK&#304;ML&#304;KNO,ADI,SOYADI,ANNEADI,BABAADI,DOGUMYER&#304;,DOGUMTAR&#304;H&#304;,ADR_MUHTAR,ADR_ILCE,ADR_IL FROM [data$] WHERE TCK&#304;ML&#304;KNO=" & verginosu
Set Baglanti = CreateObject("ADODB.Connection")
    With Baglanti
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Properties("Extended Properties").Value = "Excel 8.0"
        .Properties("Data Source").Value = Kaynak3
        .CursorLocation = adUseServer
        .Mode = adModeReadWrite
        .Open
    End With

    If Err = 0 Then
    Set Kayit1 = CreateObject("ADODB.Recordset")
    With Kayit1
        .ActiveConnection = Baglanti
        .CursorLocation = adUseServer
        .CursorType = adOpenKeyset
        .LockType = adLockOptimistic
        .Source = SQLStr
        .Open
    End With
 '***********************************************************************
    If Kayit1.RecordCount = 1 Then
          Cells(CurrentRow, "B").Value = Kayit1("ADI")
          Cells(CurrentRow, "C").Value = Kayit1("SOYADI")
          Cells(CurrentRow, "D").Value = Kayit1("BABAADI")
          Cells(CurrentRow, "E").Value = Kayit1("ANNEADI")
          Cells(CurrentRow, "F").Value = Kayit1("DOGUMYER&#304;")
          Cells(CurrentRow, "G").Value = Kayit1("DOGUMTAR&#304;H&#304;")
          Cells(CurrentRow, "AA").Value = Kayit1("ADR_MUHTAR")
          Cells(CurrentRow, "AB").Value = Kayit1("ADR_ILCE")
    Else
        MsgBox "Arad&#305;&#287;&#305;n&#305;z Kay&#305;t Bulunamad&#305;.", vbInformation, "Bilgi"
        UserForm1.Show
    End If
Else
Son:
    MsgBox "Ba&#287;lant&#305; Hatas&#305;.Kontrol Ediniz", vbInformation, "Bilgi"
End If

If CBool(Kayit1.State And adStateOpen) = True Then Kayit1.Close
Set Kayit1 = Nothing
If CBool(Baglanti.State And adStateOpen) = True Then Baglanti.Close
Set Baglanti = Nothing
Set FSO = Nothing
Target.Offset(1, 0).Select
'Application.EnableEvents = True
End Sub

mükerrer kayıt için izin sorgusunu yaptıramadım nasıl olmalı?

hsayar · 28 Aralık 2007

Hocam eski kodda düzenleme yaptım şimdi bu seferde Aynı kayıt var devam edecekmisiniz hayır deyince kırmızı satırda hata veriyor nasıl şabilirm.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [A4:A65536]) Is Nothing Then Exit Sub
    If IsEmpty(Target) Then
        Range("B" & Target.Row & ":AB" & Target.Row).Select
        Selection.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Cells(Target.Row, "A") <> "" Then
    SAY = WorksheetFunction.CountIf(Columns(Target.Column), Target)
    If SAY > 1 Then
    Set BUL = Columns(Target.Column).Find(Target)
    If Not BUL Is Nothing Then
    ADRES = BUL.Address
    Do
    If Cells(Target.Row, "A") = Cells(BUL.Row, "A") Then
    SATIR = IIf(SATIR = "", BUL.Row & Space(1), SATIR & ", " & BUL.Row & Space(1))
    End If
    Set BUL = Columns(Target.Column).FindNext(BUL)
    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    GoTo UYARI
    End If: End If: End If
    GoTo Baglan
UYARI:     ONAY = MsgBox("Bu kay&#305;t daha &#246;nce a&#351;a&#287;&#305;daki sat&#305;rlarda girilmi&#351;tir !" & Chr(10) & Chr(10) & SATIR & Chr(10) & Chr(10) & "&#304;&#351;leme devam etmek istiyor musunuz?", vbYesNo + vbCritical, "D&#304;KKAT !")
    If ONAY = vbNo Then
        Range("A" & Target.Row & ":AB" & Target.Row).Select
        Selection.ClearContents
        'Target.Select
        Target.Offset(0, 0).Select
        Exit Sub
    End If
    If Target.Value = "" Then Exit Sub
    '*****************************************************************
'Ripek - 26/12/2007

Baglan:
If Intersect(Target, [A4:A65536]) Is Nothing Then Exit Sub
Dim Baglanti As ADODB.Connection
Dim Kayit1 As ADODB.Recordset
Dim FSO As Object
Dim SQLStr, Kaynak, tcno As String
'***********************************************************************
CurrentRow = Target.Row
CurrentValue = Target.Value

Kaynak = Application.ThisWorkbook.Path & "\" & "Tckimlik.xls"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(Kaynak) = False Then
MsgBox Kaynak & " " & " Dosyas&#305; Bulunamad&#305;.", vbInformation, "Bilgi"
Exit Sub
End If

[B][color="red"]tcno = Target.Value[/color][/B]
SQLStr = "SELECT TCK&#304;ML&#304;KNO,ADI,SOYADI,ANNEADI,BABAADI,DOGUMYER&#304;,DOGUMTAR&#304;H&#304;,ADR_MUHTAR,ADR_ILCE,ADR_IL FROM [data$] WHERE TCK&#304;ML&#304;KNO=" & tcno

Set Baglanti = CreateObject("ADODB.Connection")
    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
    Set Kayit1 = CreateObject("ADODB.Recordset")
    With Kayit1
        .ActiveConnection = Baglanti
        .CursorLocation = adUseServer
        .CursorType = adOpenKeyset
        .LockType = adLockOptimistic
        .Source = SQLStr
        .Open
    End With
 '***********************************************************************

    If Kayit1.RecordCount = 1 Then
          Cells(CurrentRow, "B").Value = Kayit1("ADI")
          Cells(CurrentRow, "C").Value = Kayit1("SOYADI")
          Cells(CurrentRow, "D").Value = Kayit1("BABAADI")
          Cells(CurrentRow, "E").Value = Kayit1("ANNEADI")
          Cells(CurrentRow, "F").Value = Kayit1("DOGUMYER&#304;")
          Cells(CurrentRow, "G").Value = Kayit1("DOGUMTAR&#304;H&#304;")
          Cells(CurrentRow, "AA").Value = Kayit1("ADR_MUHTAR")
          Cells(CurrentRow, "AB").Value = Kayit1("ADR_ILCE")
    Else
        MsgBox "Arad&#305;&#287;&#305;n&#305;z Kay&#305;t Bulunamad&#305;.", vbInformation, "Bilgi"
        UserForm1.Show
    End If
Else
son:
    MsgBox "Ba&#287;lant&#305; Hatas&#305;.Kontrol Ediniz", vbInformation, "Bilgi"
End If

If CBool(Kayit1.State And adStateOpen) = True Then Kayit1.Close
Set Kayit1 = Nothing
If CBool(Baglanti.State And adStateOpen) = True Then Baglanti.Close
Set Baglanti = Nothing
Set FSO = Nothing
End Sub

Recep İpek · 28 Aralık 2007

Aradaki GoTo Baglan satırını kaldırarak deneyiniz.

hsayar · 28 Aralık 2007

bu seferde
Hayır dedikçe kısır döngüye giriyor, mecburen evet diyorum tcno silinmiş olduğu içinde tcno = Target.Value satırında hata veriyor.

Recep İpek · 28 Aralık 2007

GoTo Baglan
UYARI: ONAY = MsgBox("Bu kayıt daha önce aşağıdaki satırlarda girilmiştir !" & Chr(10) & Chr(10) & SATIR & Chr(10) & Chr(10) & "İşleme devam etmek istiyor musunuz?", vbYesNo + vbCritical, "DİKKAT !")
If ONAY = vbNo Then
Range("A" & Target.Row & ":AB" & Target.Row).Select
Selection.ClearContents
'Target.Select
Target.Offset(0, 0).Select
Exit Sub
End If

Normalde buradaki Exit Sub ile makrodan çıkılması gerekiyor.Dolayısıyla Baglan bölümünü görmemesi lazım.Bir noktayı atlıyoruz sanırım.

hsayar · 28 Aralık 2007

bende öyle biliyorum belleğe aldım şimdi evde örnek hazıralyıp eklyecem gözatarsanız seviniirm.

hsayar · 28 Aralık 2007

Hatalı dosyayı ekledim

hsayar · 29 Aralık 2007

sorunum devam ediyor yardımlarınızı bekliyorum.

hsayar · 29 Aralık 2007

Arkadaşlar çözümü buldum ilgilenenlere

Kod:

....
.....
UYARI:     ONAY = MsgBox("Bu kay&#305;t daha &#246;nce a&#351;a&#287;&#305;daki sat&#305;rlarda girilmi&#351;tir !" & Chr(10) & Chr(10) & SATIR & Chr(10) & Chr(10) & "&#304;&#351;leme devam etmek istiyor musunuz?", vbYesNo + vbCritical, "D&#304;KKAT !")
    If ONAY = vbNo Then
        Range("b" & Target.Row & ":AB" & Target.Row).Select:        Selection.ClearContents
        Target.Select
        Range("a" & Target.Row).Select:     Selection.ClearContents
        Exit Sub
    End If
    '*****************************************************************
'Ripek - 26/12/2007
...
...

UYARI: ile başlayan satırları 'Ripek açıklma kısmına kadar değiştirdilermi sorun çözülüyor. anladığım kadarıyla sorun biz eğer kayıt mükerrerse veriyi sorguladığımız alan ve diğer alanların tümünü birden siliyorduk...
şimdi ben önce veriyi aldığımız alanları B:G aralığı daha sonra sorgulama kriterini silince hata kalktı.

Tam çözüm ise

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
'1)AYNI KLAS&#214;RDEK&#304; VER&#304;TABNAI DOSYASINDAN A S&#220;TUNUNDAK&#304; VER&#304;Y&#304; SORGULAR VARSA BEL&#304;RT&#304;LEN S&#220;TUNLARA VER&#304;LER&#304; KOPYALAR.
'2) SORGULAMA SAYFASINDAK&#304; A S&#220;TUNUNDAK&#304; VER&#304; M&#220;KERRER G&#304;RLD&#304;&#286;&#304;NDE DEVAM ONAYI SORAR.
    If Intersect(Target, [A4:A65536]) Is Nothing Then Exit Sub
    If IsEmpty(Target) Then
        Range("B" & Target.Row & ":AB" & Target.Row).Select
        Selection.ClearContents
        Target.Select
        Exit Sub
    End If
    
    If Cells(Target.Row, "A") <> "" Then
    SAY = WorksheetFunction.CountIf(Columns(Target.Column), Target)
    If SAY > 1 Then
    Set BUL = Columns(Target.Column).Find(Target)
    If Not BUL Is Nothing Then
    ADRES = BUL.Address
    Do
    If Cells(Target.Row, "A") = Cells(BUL.Row, "A") Then
    SATIR = IIf(SATIR = "", BUL.Row & Space(1), SATIR & ", " & BUL.Row & Space(1))
    End If
    Set BUL = Columns(Target.Column).FindNext(BUL)
    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    GoTo UYARI
    End If: End If: End If
    GoTo Baglan
UYARI:     ONAY = MsgBox("Bu kay&#305;t daha &#246;nce a&#351;a&#287;&#305;daki sat&#305;rlarda girilmi&#351;tir !" & Chr(10) & Chr(10) & SATIR & Chr(10) & Chr(10) & "&#304;&#351;leme devam etmek istiyor musunuz?", vbYesNo + vbCritical, "D&#304;KKAT !")
    If ONAY = vbNo Then
        Range("b" & Target.Row & ":AB" & Target.Row).Select:        Selection.ClearContents
        Target.Select
        Range("a" & Target.Row).Select:     Selection.ClearContents
        Exit Sub
    End If
    '*****************************************************************
'Ripek - 26/12/2007

Baglan:
If Intersect(Target, [A4:A65536]) Is Nothing Then Exit Sub
Dim Baglanti As ADODB.Connection
Dim Kayit1 As ADODB.Recordset
Dim FSO As Object
Dim SQLStr, Kaynak, tcno As String
'***********************************************************************
CurrentRow = Target.Row
CurrentValue = Target.Value

Kaynak = Application.ThisWorkbook.Path & "\" & "Tckimlik.xls"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(Kaynak) = False Then
MsgBox Kaynak & " " & " Dosyas&#305; Bulunamad&#305;.", vbInformation, "Bilgi"
Exit Sub
End If


tcno = Target.Value
SQLStr = "SELECT TCK&#304;ML&#304;KNO,ADI,SOYADI,ANNEADI,BABAADI,DOGUMYER&#304;,DOGUMTAR&#304;H&#304;,ADR_MUHTAR,ADR_ILCE,ADR_IL FROM [data$] WHERE TCK&#304;ML&#304;KNO=" & tcno

Set Baglanti = CreateObject("ADODB.Connection")
    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
    Set Kayit1 = CreateObject("ADODB.Recordset")
    With Kayit1
        .ActiveConnection = Baglanti
        .CursorLocation = adUseServer
        .CursorType = adOpenKeyset
        .LockType = adLockOptimistic
        .Source = SQLStr
        .Open
    End With
 '***********************************************************************

    If Kayit1.RecordCount = 1 Then
          Cells(CurrentRow, "B").Value = Kayit1("ADI")
          Cells(CurrentRow, "C").Value = Kayit1("SOYADI")
          Cells(CurrentRow, "D").Value = Kayit1("BABAADI")
          Cells(CurrentRow, "E").Value = Kayit1("ANNEADI")
          Cells(CurrentRow, "F").Value = Kayit1("DOGUMYER&#304;")
          Cells(CurrentRow, "G").Value = Kayit1("DOGUMTAR&#304;H&#304;")
          Cells(CurrentRow, "AA").Value = Kayit1("ADR_MUHTAR")
          Cells(CurrentRow, "AB").Value = Kayit1("ADR_ILCE")
    Else
        MsgBox "Arad&#305;&#287;&#305;n&#305;z Kay&#305;t Bulunamad&#305;.", vbInformation, "Bilgi"
        UserForm1.Show
    End If
Else
son:
    MsgBox "Ba&#287;lant&#305; Hatas&#305;.Kontrol Ediniz", vbInformation, "Bilgi"
End If

If CBool(Kayit1.State And adStateOpen) = True Then Kayit1.Close
Set Kayit1 = Nothing
If CBool(Baglanti.State And adStateOpen) = True Then Baglanti.Close
Set Baglanti = Nothing
Set FSO = Nothing
End Sub

hsayar · 29 Aralık 2007

Kopyadan uyarlamayı becerdik vakti olan ve konunun uzmanı bir arkadaşa soru işaretli satırları açıklarsa sevinirim.
Ayrıca
1) Birden falza kayıt olsa Yani ( If Kayit1.RecordCount > 1 Then) durumunda kod nasıl olur içlerinden seçim yapma imkanı olurmu (Çok uç bir ihtimal olduğunu biliyorum)
Current.row ne demektir?

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [A4:A65536]) Is Nothing Then Exit Sub                      'a4:a65536 aral&#305;&#287;&#305; de&#287;i&#351;memi&#351;se &#231;&#305;k
    If IsEmpty(Target) Then                                                         'de&#287;i&#351;en alan bo&#351;sa
        Range("B" & Target.Row & ":AB" & Target.Row).Select                         'B:AB aral&#305;&#287;&#305;ndaki sat&#305;rlar&#305; se&#231;
        Selection.ClearContents                                                     'i&#231;eri&#287;ini bo&#351;alt
        Target.Select                                                               'de&#287;i&#351;en h&#252;creyi se&#231;
    Exit Sub: End If                                                                'prosod&#252;rden &#231;&#305;k
    
    'm&#252;kerrer kay&#305;t kontol&#252;
    If Cells(Target.Row, "A") <> "" Then                                            'A s&#252;tununda de&#287;i&#351;en alan bo&#351; de&#287;ilse
    SAY = WorksheetFunction.CountIf(Columns(Target.Column), Target)                 's&#252;tundaki hedef de&#287;eri ta&#351;&#305;yan verileri say.
    If SAY > 1 Then                                                                 '1 den fazla ise
    Set BUL = Columns(Target.Column).Find(Target)                                   'de&#287;eri ta&#351;yan h&#252;creleri bul
    If Not BUL Is Nothing Then                                                      '?
    ADRES = BUL.Address                                                             '?
    Do                                                                              '?
    If Cells(Target.Row, "A") = Cells(BUL.Row, "A") Then                            '?
        SATIR = IIf(SATIR = "", BUL.Row & Space(1), SATIR & ", " & BUL.Row & Space(1))  '?
    End If
    Set BUL = Columns(Target.Column).FindNext(BUL)                                  '?
    Loop While Not BUL Is Nothing And BUL.Address <> ADRES                          '?
    GoTo UYARI                                                                      'm&#252;kerrer kay&#305;t uyar&#305; ver alt makrosuna git
    End If: End If: End If
    GoTo Baglan                                                                     'm&#252;kerrer kay&#305;t yoksa ba&#287;lan alt makrosuna git
UYARI:
    ONAY = MsgBox("Bu kay&#305;t daha &#246;nce a&#351;a&#287;&#305;daki sat&#305;rlarda girilmi&#351;tir !" & Chr(10) & Chr(10) & SATIR & Chr(10) & _
           Chr(10) & "&#304;&#351;leme devam etmek istiyor musunuz?", vbYesNo + vbCritical, "D&#304;KKAT !")   'm&#252;kerrer kay&#305;t devam edecekmisiniz sorusunu sor?
    If ONAY = vbNo Then                                                                         'devam edilmeyecekse
        Range("b" & Target.Row & ":AB" & Target.Row).Select:        Selection.ClearContents     'b:ab aral&#305;&#287;&#305;n&#305; sil
        Target.Select:                                              Selection.ClearContents     'de&#287;i&#351;en h&#252;creyi se&#231; ve sil.
        Exit Sub                                                                                'makrodan &#231;&#305;k
    End If                                                                                      'kontrolden &#231;&#305;k
    '*****************************************************************
'Ripek - 26/12/2007
'veri taban&#305;na ba&#287;lan
Baglan:
Dim Baglanti As ADODB.Connection                                                    'ADODB ba&#287;lant&#305; de&#287;i&#351;keni tan&#305;mla
Dim Kayit1 As ADODB.Recordset                                                       'ADODB kay&#305;t alan de&#287;i&#351;keni tan&#305;mla
Dim FSO As Object                                                                   'Dosya kontol objesi tan&#305;mla
Dim SQLStr, Kaynak, tcno As String                                                  'Sorgulanacak alanlar, kaynak dosya, ve sorgulanacak kritere ili&#351;kin tan&#305;mlar&#305; yap
'***********************************************************************
CurrentRow = Target.Row                                                             '?
CurrentValue = Target.Value                                                         '?

Kaynak = Application.ThisWorkbook.Path & "\" & "Tckimlik.xls"                       'Kaynak olarak bu kitab&#305;n oldu&#287;u klas&#246;rde veri taban&#305; belirt
Set FSO = CreateObject("Scripting.FileSystemObject")                                'Dosya kontorol objesine de&#287;er ata
If FSO.FileExists(Kaynak) = False Then                                              'Kaynak dosya var m&#305; yokmu bak, yoksa
    MsgBox Kaynak & " " & " Dosyas&#305; Bulunamad&#305;.", vbInformation, "Bilgi"                'Uyar&#305; ver,
    Exit Sub                                                                            'makrodan &#231;&#305;k
End If                                                                              'kontrolden &#231;&#305;k


tcno = Target.Value                                                                 'Sorgulanacak de&#287;eri ata
SQLStr = "SELECT TCK&#304;ML&#304;KNO,ADI,SOYADI,ANNEADI,BABAADI,DOGUMYER&#304;,DOGUMTAR&#304;H&#304;,ADR_MUHTAR,ADR_ILCE,ADR_IL FROM [data$] WHERE TCK&#304;ML&#304;KNO=" & tcno
'Sorgulanacak ba&#351;l&#305;klar&#305; ve sorgulanacak kriteri yaz
Set Baglanti = CreateObject("ADODB.Connection")             'ba&#287;lant&#305;y&#305; 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&#287;er ba&#287;lant&#305;da hata yoksa
        Set Kayit1 = CreateObject("ADODB.Recordset")    'kay&#305;t ba&#287;lant&#305;s&#305;n&#305; kur
        With Kayit1
            .ActiveConnection = Baglanti
            .CursorLocation = adUseServer
            .CursorType = adOpenKeyset
            .LockType = adLockOptimistic
            .Source = SQLStr
            .Open
        End With
 '***********************************************************************

        If Kayit1.RecordCount = 1 Then                      '1 adet kay&#305;t bulundu ise
          Cells(CurrentRow, "B").Value = Kayit1("ADI")          'bulunanlar&#305; yaz
          Cells(CurrentRow, "C").Value = Kayit1("SOYADI")       '..   ""...
          Cells(CurrentRow, "D").Value = Kayit1("BABAADI")      '..   ""...
          Cells(CurrentRow, "E").Value = Kayit1("ANNEADI")      '..   ""...
          Cells(CurrentRow, "F").Value = Kayit1("DOGUMYER&#304;")    '..   ""...
          Cells(CurrentRow, "G").Value = Kayit1("DOGUMTAR&#304;H&#304;")  '..   ""...
          Cells(CurrentRow, "AA").Value = Kayit1("ADR_MUHTAR")  '..   ""...
          Cells(CurrentRow, "AB").Value = Kayit1("ADR_ILCE")    '..   ""...
          Range("h" & Target.Row).Select                        'h s&#252;tununu se&#231;
        Else
            MsgBox "Arad&#305;&#287;&#305;n&#305;z Kay&#305;t Bulunamad&#305;.", vbInformation, "Bilgi"       'uyar&#305; ver
            UserForm1.Show                                                      'kay&#305;t eklemek i&#231;in user forma ge&#231;
        End If
    Else                                                        'ba&#287;lant&#305;da hata varsa
son:
    MsgBox "Ba&#287;lant&#305; Hatas&#305;.Kontrol Ediniz", vbInformation, "Bilgi" 'uayr&#305; ver
End If

If CBool(Kayit1.State And adStateOpen) = True Then Kayit1.Close '?
Set Kayit1 = Nothing    'de&#287;i&#351;keni haf&#305;zadan sil
If CBool(Baglanti.State And adStateOpen) = True Then Baglanti.Close '?
Set Baglanti = Nothing  'de&#287;i&#351;keni haf&#305;zadan sil
Set FSO = Nothing       'de&#287;i&#351;keni haf&#305;zadan sil
End Sub

Recep İpek · 29 Aralık 2007

Birden fazla kayıt olursa tüm kayıtları sayfaya aktarmak için aşağıdaki örneği inceleyiniz.

Kod:

'.....
If Kayit1.RecordCount > 0 Then
                Range("a3:h65536").ClearContents
                sat = 2
                Kayit1.MoveFirst
                For i = 1 To Kayit1.RecordCount
                    Cells(sat + i, "a").Value = i
                    Cells(sat + i, "b").Value = Kayit1("SIRKET")
                    Cells(sat + i, "c").Value = Kayit1("SICIL_NO")
                    Cells(sat + i, "d").Value = Kayit1("ADI")
                    Cells(sat + i, "e").Value = Kayit1("SOYADI")
                    Cells(sat + i, "f").Value = Format(Kayit1("GIR_TAR"), "dd/mm/yyyy")
                    Cells(sat + i, "g").Value = Format(Kayit1("CIK_TAR"), "dd/mm/yyyy")
                    Cells(sat + i, "h").Value = Kayit1("DEPART")
                    Cells(sat + i, "i").Value = Kayit1("D_ID_S")
                Kayit1.MoveNext
                Next i
                Kayit1.MoveFirst
            MsgBox "&#304;&#351;lem Ba&#351;ar&#305;yla Tamamland&#305;.", vbInformation, "Bilgi"
        Else
            MsgBox "Arad&#305;&#287;&#305;n&#305;z Kay&#305;t Bulunamad&#305;.", vbInformation, "Bilgi"
        End If
'....

CurrentRow ise değişken ismi.Yani aktif hücrenin Satır sayısını bulmak için yazmıştım.

CurrentValue de aktif hücredeki değeri hafızada tutuyor.

Bu değerler userformda kullanıldı.

Eğer birden fazla kayıt çekip,içinden sadece bir veya birkaç tanesini kullanmak istiyorsanız Recordset'in Find özelliğini kullanabilirsiniz.

Daha detaylı bilgi için ADO ve Recordset ile ilgili forumdaki kaynakları araştırabilirsiniz.

hsayar · 30 Aralık 2007

ozaman olmayan veriyi userformdan veritabanınıa eklemk için Currenyvalue i Public olarak tanımlamak gerekecek galiba.
bende veriyi nasıl eklerim diye kafa patlatıyordum.
artık p.tesi devam edeceğim

hsayar · 22 Ocak 2008

Ripek' Alıntı:

Birden fazla kayıt olursa tüm kayıtları sayfaya aktarmak için aşağıdaki örneği inceleyiniz.

Kod:

'.....
If Kayit1.RecordCount > 0 Then
                Range("a3:h65536").ClearContents
                sat = 2
                Kayit1.MoveFirst
                For i = 1 To Kayit1.RecordCount
                    Cells(sat + i, "a").Value = i
                    Cells(sat + i, "b").Value = Kayit1("SIRKET")
                    Cells(sat + i, "c").Value = Kayit1("SICIL_NO")
                    Cells(sat + i, "d").Value = Kayit1("ADI")
                    Cells(sat + i, "e").Value = Kayit1("SOYADI")
                    Cells(sat + i, "f").Value = Format(Kayit1("GIR_TAR"), "dd/mm/yyyy")
                    Cells(sat + i, "g").Value = Format(Kayit1("CIK_TAR"), "dd/mm/yyyy")
                    Cells(sat + i, "h").Value = Kayit1("DEPART")
                    Cells(sat + i, "i").Value = Kayit1("D_ID_S")
                Kayit1.MoveNext
                Next i
                Kayit1.MoveFirst
            MsgBox "İşlem Başarıyla Tamamlandı.", vbInformation, "Bilgi"
        Else
            MsgBox "Aradığınız Kayıt Bulunamadı.", vbInformation, "Bilgi"
        End If
'....

Daha detaylı bilgi için ADO ve Recordset ile ilgili forumdaki kaynakları araştırabilirsiniz.

hocam dediğiniz yerleri araştırdım ve korktuğum şimdi başıma geldi yalnız sorum şu şekilde olursa nasıl olmalı

birden fazla kayıt bulduğunda bulunanları listbox veya listwieve listeleyecek, listenenlerden istenilenin üzerine çift tıklanınca sayfada ilgili target.row satırında belirtilmiş sütunlara dağılacak