Açık sayfadan çoklu veri alma

[ralermo]

Ekte gönderdiğim iki dosya arasında veri alışı yapmak istiyorum. Gerekli açıklama "YF" dosyasının içinde mevcut.

Yardımlarınız için şimdiden teşekkürler.

 

[Orion1]

Dosyanız ektedir.
Her iki dosyada ayni jklasör içinde olmalı.
Diğer dosyanın açık olmasına gerek yoık.Kapalı ikende veriler alınabilir.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim conn As Object, rs As Object, sat As Long
If Intersect(Target, [D10]) Is Nothing Then Exit Sub
On Error Resume Next
Range("B16:D23").ClearContents
If Target.Value = "" Then Exit Sub
If Not IsNumeric(Target.Value) Then Exit Sub
Set conn = CreateObject("AdoDb.Connection")
Set rs = CreateObject("AdoDb.Recordset")
conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & _
ThisWorkbook.Path & "\Sat Fat.xls;extended properties=""excel 8.0;hdr=yes"""
rs.Open "Select * from [BEKLER$] where kod=" & _
CDbl(Target.Value) & " order by Fatura_Tarihi,No;", conn, 1, 1
sat = 16
If rs.RecordCount > 0 Then rs.movefirst
Do While Not rs.EOF
    Cells(sat, "B").Value = rs("Fatura_Tarihi")
    Cells(sat, "C").Value = rs("No")
    Cells(sat, "D").Value = rs("Fatura")
    rs.movenext
    sat = sat + 1
Loop
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
End Sub

 

[ralermo]

Hızlı cevap için ayrıca çok ama çok teşekkürler. Bu kod gerçekten işimi gördü..

 

[Orion1]

Hızlı cevap için ayrıca çok ama çok teşekkürler. Bu kod gerçekten işimi gördü..

Rica ederim.
İyi çalışmalar.