If Kayit1.RecordCount > 1 dumunda ilgili satırları listwieve atmak

[hsayar]

konunun kaynağı aşağıdaki link olup
http://www.excel.web.tr/showthread.php?t=42349


şu anda Birden fazla kayıt olursa tüm kayıtları Listwiev/Listbox nesnelerine aktarmak sorununu yaşamaktayım.

Sn ripekin sayfa için kodları aşağıdadır.

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

'.....
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

 

[hsayar]

güncel........

 

[hsayar]

güncel........

 

[hsayar]

konuyu tekrar izah edeyim mesala aşağıdaki kodlarımız var

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

Dim Hcr As Range: Dim i%, y%: Dim arrStr()
'seçili satırları diziye al
For Each Hcr In ActiveWindow.Selection.Cells
    If Hcr.Column = 1 Then
        ReDim Preserve arrStr(y)
        arrStr(y) = Hcr.Row:        y = y + 1
        satirlar = Hcr.Row & vbCrLf & satirlar
    End If
Next
'seçili satırlar dizisini kontrol et
For i = 0 To UBound(arrStr)
    'boş olanlar için b:ab aralığını sil
    If Cells(arrStr(i), 1).Value = "" Then
        Cells(arrStr(i), 2).Select
        Range(Cells(arrStr(i), "b"), Cells(arrStr(i), "ab")).Select
        Selection.ClearContents
    'dolu olanlar için mükerrer kayıt kontorlüne atla ama nasıl
'    ElseIf Cells(arrStr(i), 1).Value <> "" Then
'    GoTo YAZ
    End If
Next i
Cells(WorksheetFunction.Min(arrStr), "a").Select
Exit Sub:    End If                                                                'prosodürden çık
'*******/*/*/*/*/**/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*//*/*//*/*/*/*///**/*//*/*/*/**
YAZ:
    'mükerrer kayıt kontolü
    If Cells(Target.Row, "A") <> "" Then                                            'A sütununda değişen alan boş değilse
    SAY = WorksheetFunction.CountIf(Columns(Target.Column), Target)                 'sütundaki hedef değeri taşıyan verileri say.
    If SAY > 1 Then                                                                 '1 den fazla ise
    Set BUL = Columns(Target.Column).Find(Target)                                   'değeri taşyan hü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ükerrer kayıt uyarı ver alt makrosuna git
    End If: End If: End If
    GoTo Baglan                                                                     'mükerrer kayıt yoksa bağlan alt makrosuna git
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 !")   'mükerrer kayıt devam edecekmisiniz sorusunu sor?
    If ONAY = vbNo Then                                                                         'devam edilmeyecekse
        Range("b" & Target.Row & ":AB" & Target.Row).Select:        Selection.ClearContents     'b:ab aralığını sil
        Target.Select:                                              Selection.ClearContents     'değişen hücreyi seç ve sil.
        Exit Sub                                                                                'makrodan çık
    End If                                                                                      'kontrolden çık
    '*****************************************************************
'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 = Application.ThisWorkbook.Path & "\" & "Tckimlik.xls"                       'Kaynak olarak bu kitabın olduğu klasörde veri tabanı belirt
Set FSO = CreateObject("Scripting.FileSystemObject")                                'Dosya kontorol objesine değer ata
If FSO.FileExists(Kaynak) = False Then                                              'Kaynak dosya var mı yokmu bak, yoksa
    MsgBox Kaynak & " " & " Dosyası Bulunamadı.", vbInformation, "Bilgi"                'Uyarı ver,
    Exit Sub                                                                            'makrodan çık
End If                                                                              'kontrolden çık


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 "
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(currentrow, "B").Value = Kayit1("ADI")          'bulunanları 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İ")    '..   ""...
          Cells(currentrow, "G").Value = Kayit1("DOGUMTARİHİ")  '..   ""...
          Cells(currentrow, "AA").Value = Kayit1("ADR_MUHTAR")  '..   ""...
          Cells(currentrow, "AB").Value = Kayit1("ADR_ILCE") & "/" & Kayit1("ADR_IL")   '..   ""...
          'Cells(currentrow, "AL").Value = Kayit1("NFS_MHKY")
          
          Range("h" & Target.Row).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

bu kodlar ile veritabanımızda 1 ade tcno varsa sayfada ilgili yerler doluyor.
peki
If Kayit1.RecordCount > 1 Then

durumu olduğunda

userform2.show desek

ve bu userform2 de bir adet listwiev olsa buraya kapalı dosyada aynı tcnoya sahip kayıtlar gelse (uç bir ihtimal maa sorgulana bir telefon no ise olabilir(aynı evde oturuyordur)

listwievde istediğim satıra çift tıklayınca sayfaya veriler inse diyorum.

çok şey istiyorum biliyorum yardımlarınızı bekliyorum.
Listwiev/Listbox/spreadsheet hangisi daha hızlı veya kolyaınız geliyorsa o olsun.

 

[hsayar]

kapalı dosyadan gelen kayıtları listwiev veya benzeri nesneya alamzmıyız?

 

[hsayar]

hepten monolog gibi olmuş Record.count > 0 olduğunda Örnekteki gibi başlıkları Çalışma sayfası yerine,
1) çift boyutlu diziye
2) Listboxa
3) listwiev
almak nasıl olmalıdır?
Lütfen yardım ediniz