Excel dosyaları arasında veri alışverişi

[erh_tun]

Merhaba iki excel dosyası arasında veri alışverişi yapmam gerekiyor. A.xls dosyasındaki işaretlediğim hücreleri B.xls dosyasındaki aralığa kopyalayacak bir macroya ihtiyacım var. Bu macroyu asıl yazabileceğim konusunda yardımcı olursanız çok memnun olurum. Daha iyi anlaşılması için dosyalarıda gönderiyorum.

 

[Orion1]

Dosyanız ektedir.
2 dosyanında ayni klaör içinde olması lazım.
Kodların çalışablimesi için
Ben VBE'den referenceden microsoft activex data object 2.8 library seçtim.

Sub aktar()
Dim conn As ADODB.Connection, rs As ADODB.Recordset
Dim sat As Long, k As Range
Sheets("sayfa1").Select
Range("B2:Y65536").ClearContents
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
Application.ScreenUpdating = False
conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\A.xls;extended properties=""excel 8.0;hdr=yes"""
rs.Open "select * from [Sayfa1$];", conn, adOpenKeyset, adLockReadOnly
rs.MoveFirst
Do While Not rs.EOF
    Cells(rs(2).Value + 1, rs(3).Value + 2).Value = rs(4).Value
    rs.MoveNext
Loop
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "Aktarım tamamlandı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[erh_tun]

İlgilendiğiniz için çok teşekkür ederim. Tam istediğim gibi çalışıyor.

 

[Orion1]

İlgilendiğiniz için çok teşekkür ederim. Tam istediğim gibi çalışıyor.

Rica ederim.
iyi çalışmalar.

 

[Orion1]

Kayıt kümesini ve bağlantıyı kapatmayı unutmuşum.
Bunları düzelttim.
Dosyayı güncelledim.
2 numaralı mesajdan dosyayı inderebilirsiniz.

 

[erh_tun]

Kayıt kümesini ve bağlantıyı kapatmayı unutmuşum.
Bunları düzelttim.
Dosyayı güncelledim.
2 numaralı mesajdan dosyayı inderebilirsiniz.

Ben ilk gönderdiğiniz ile işlerimi hallettim. Beni büyük bir yükten kurtardınız. Tekrar teşekkür ederim. Kolay gelsin...