başka excel dosyasından veri aktarma

[redje]

Merhabalar;

Birçok veri aktarma örneğini denedim aktarmak istedğim dosya office 97 özel bir programdan oluştuğu için aktarma yapmadı fakat aşağıdaki örneği denememde bilgi alışı oldu

Aşağıdaki makro enson veriyi aktarmakta benim isteğim son bilgiyi değilde a ile z arasındaki tüm bilgileri taşısın ayrıca bu makro klasörde nekadar excel dosyası varsa hepsine bakıp aktarıyor. Makroda dosya ismini yazdığım excel dosyasından bilgiyi aktarırsa daha uygun olur Bu şekilde düzenleme yaparak yardımcı olursanız sevinirim.

İyi Çalışmalar.



Sub Verileri_Al()
Application.ScreenUpdating = False
Yol = ThisWorkbook.Path & "\"
Set COfs = CreateObject("Scripting.FileSystemObject")
Set Ana = Workbooks("Anasayfa.xlsm").Sheets("Sayfa1")

For Each Dosya In COfs.GetFolder(Yol).Files
If Right(Dosya.Name, 3) = "xls" Then
Set WBook = Workbooks.Open(Yol & Dosya.Name)
For i = 1 To Workbooks(Dosya.Name).Worksheets.Count
Set Sayfa = WBook.Sheets(i)
SDS = Sayfa.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
son = Ana.[A65536].End(3).Row + 1
Sayfa.Range("B" & SDS & ":Z" & SDS).Copy Ana.Range("B" & son)
Ana.Range("A" & son) = WBook.Sheets(i).Name
Next
WBook.Close 0
End If
Next

Application.ScreenUpdating = True
MsgBox "İşlem Tamam...", vbInformation, "dEdE Başarılar Diler..."
End Sub

 

[redje]

merhabalar,

bu konuda bilgili arkadaşlar yadımcı olurlarsa sevinirim

iyi çalışmalar.

 

[redje]

merhaba;

ucundan tutarsanız sevinirim

iyi çalışmalar.

 

[redje]

merhabalar,

alttaki makro birnevi işimi görüyor bu şekliyle dosya hangi klasörde açıksa otomatik ordaki bilgi dosyasını açmakta kendim isteğim bir klasördeki örneğin c:\yedek\bilgi.xls eklemek istersem nere eklemem gerekir birde makroyu hangi sayfada çalıştırırsam o sayfaya taşıyor kendi isdediğim örneğin sayfa 7 ye aktarılacak şekirlde eklenirse işimi daha net görür

bilgi için teşekkürler


Sub kapali_aktarYOKLAMAİÇİN()
Range("b1:B" & Rows.Count).ClearContents
Range("A1:A" & Rows.Count).ClearContents
Dim conn As Object, rs As Object
Set conn = CreateObject("AdoDb.Connection")
Set rs = CreateObject("AdoDb.Recordset")
conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & _
"\bilgi.xls;extended properties=""excel 8.0;hdr=yes"""
rs.Open "Select * from [bilgi$];", conn, 1, 3
sat = Cells(65536, "A").End(xlUp).Row + 1
rs.movefirst
Range("A" & sat).CopyFromRecordset rs
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing

End Sub