Farklı dosyalardan bir dosyaya veri çekme

[vulkan]

Selam,
101 ve 102 ( ve daha sonra 103, 104...) dosyalarındaki verileri, liste dosyasına çekmek istiyorum.
Mümkün mü?
Teşekkürler

 

[hamitcan]

Forumda, kapalı dosyadan veri alma ile ilgili örneklere bakmalısınız. Bu şekilde arama yaparsanız, birçok örneğe ulaşabilirsiniz.

 

[asi_kral]

Merhaba
101-102 .... olan dosyaları bir klasör oluşturun onun içinde toplayın.
liste dosyanızı bu dosyanın içerisine kopyalamayın.
Kod olarak bunu kullanabilirsiniz_?

Option Explicit
Sub veri_çek()
Dim YL As String, DSY As Variant, XCL As Excel.Application
Dim KTP As Workbook, SYF1 As Worksheet, SYF2 As Worksheet
Dim STR1 As Long, STR2 As Long
Application.ScreenUpdating = False
Set XCL = CreateObject("Excel.Application")
XCL.Visible = False
Set SYF1 = ActiveWorkbook.ActiveSheet
SYF1.Range("C3:K" & Rows.Count).ClearContents
SYF1.Range("M3:P" & Rows.Count).ClearContents
YL = ThisWorkbook.Path & "\Klasör\"
DSY = Dir(YL & "*.xls?")
Do While DSY <> ""
STR1 = Range("C" & Rows.Count).End(xlUp).Row + 1
Set KTP = XCL.Workbooks.Open(YL & DSY)
Set SYF2 = KTP.Sheets("1")
For STR2 = 9 To SYF2.Cells(21, "C").End(xlUp).Row
SYF1.Cells(STR1, "C") = SYF2.Range("E5").Value
SYF1.Cells(STR1, "D") = SYF2.Range("E6").Value
SYF1.Cells(STR1, "E") = SYF2.Range("F6").Value
SYF1.Cells(STR1, "F") = SYF2.Cells(STR2, "C")
SYF1.Cells(STR1, "G") = SYF2.Cells(STR2, "D")
SYF1.Cells(STR1, "I") = SYF2.Cells(STR2, "F")
SYF1.Cells(STR1, "J") = SYF2.Cells(STR2, "G")
SYF1.Cells(STR1, "K") = SYF2.Cells(STR2, "H")
SYF1.Cells(STR1, "M") = SYF2.Cells(STR2, "J")
SYF1.Cells(STR1, "N") = SYF2.Range("K5").Value
SYF1.Cells(STR1, "O") = SYF2.Range("K6").Value
SYF1.Cells(STR1, "P") = SYF2.Cells(STR2, "K")
STR1 = STR1 + 1
Next
KTP.Close: XCL.Quit
DSY = Dir
Loop
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation
End Sub

Dosyanız ekte.

 

[vulkan]

Üstadım süpersin, eline sağlık

 

[asi_kral]

Üstadım süpersin, eline sağlık

Kolay Gelsin.