Farklı Excel Dosyaların Veri çekme

[ant_kas_kalkan]

Merhablar excel konusunda yeniyim. İş yerinde karşılaştığımız bir sorun var.Farklı dosylardan veri çekip yeni bir excel dosyasında liste oluşturmak istiyoruz.

örnek:
1.xls
2.xls
.
.
3500.xls yani toplam 3500 dosya var. burada her dosyadan örneğin k2 hücresindeki veriyi alıp b stununa alt alta sıralaması istiyorum. acaba bunu yapmak mümkün olabilirmi. yardımcı olursanız en az 1 haftalık işi kısa bir sürede bitirmemize yardımcı olursunuz. teşekkurler

 

[N.Ziya Hiçdurmaz]

yanıt

Sub RAPORAL()
Dim dosya As Variant
On Error Resume Next
DoEvents
Sayfa1.Activate
Sheets("Rapor").[b2:c10000] = Empty
Set dosyalar = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path
Set klasor = dosyalar.GetFolder("" & yol & "\dosyalar")
Set dongual = klasor.Files
Application.ScreenUpdating = False
For Each dosya In dongual
son = Workbooks("ANADOSYA").Sheets("Rapor").Cells(65536, "b").End(xlUp).Row + 1
s = s + 1
Cells(s + 1, "c") = dosya.Name
Workbooks.Open ThisWorkbook.Path & "\dosyalar\" & Cells(s + 1, "c") & ""
Workbooks("ANADOSYA").Sheets("Rapor").Cells(son, "b") = [k2]
ActiveWorkbook.Close
Next
Sheets("Rapor").[c2:c10000] = Empty
Application.ScreenUpdating = True
End Sub

 

[ant_kas_kalkan]

çok teşekkur ederim. sizin yardımınız sayesinde 1 haftalık işi 1 saate indirdim. en kısa sürede soruma cevap verdiniz.... iyi çalışmalar

 

[betoncu]

Yardım

Sub RAPORAL()
Dim dosya As Variant
On Error Resume Next
DoEvents
Sayfa1.Activate
Sheets("Rapor").[b2:c10000] = Empty
Set dosyalar = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path
Set klasor = dosyalar.GetFolder("" & yol & "\dosyalar")
Set dongual = klasor.Files
Application.ScreenUpdating = False
For Each dosya In dongual
son = Workbooks("ANADOSYA").Sheets("Rapor").Cells(65536, "b").End(xlUp).Row + 1
s = s + 1
Cells(s + 1, "c") = dosya.Name
Workbooks.Open ThisWorkbook.Path & "\dosyalar\" & Cells(s + 1, "c") & ""
Workbooks("ANADOSYA").Sheets("Rapor").Cells(son, "b") = [k2]
ActiveWorkbook.Close
Next
Sheets("Rapor").[c2:c10000] = Empty
Application.ScreenUpdating = True
End Sub

Merhaba bu kodları uyguladım ama bir türlü olmadı. Arkadaşlar yardım edebilirmisiniz...

 

[ant_kas_kalkan]

bu kodlar daha önceden çalışıyordu. fakat şimdi bende tekrar denedim. çalıştıramadım. Daha iyi bilen bir arkadas yardımcı olursa sevinirim. şimdiden teşekkürler

 

[hamitcan]

Ziya bey'in verdiği dosyayı denedim çalıştı.