kapalı çok sayısa .xls dosyasından aynı şarta uygun verileri almak

[tlgsri88]

Merhaba,

Bir çok konu başlığı altında bir çok kod buldum fakat halledemedim bir türlü...

masaüstüne kayıtlı "veri_al" isminde bir dosyam var...
bu dosyanın içinde tam 688 adet .xls excel çalışmaları mevcut.
bu 688 tane .xls nin hepsinin isimleri farklı fakat hepsinin içinde "YATAY FORMAT" isimli sheet mevcut.
ben bu 688 tane farklı dosyanın hepsinin içindeki yatay format sheet lerindeki 6. satırlarını komple alıp açık olan excel sayfamda alt alta bu satırları getirmek istiyorum... örnek dosya ekliyorum yardımlarınız için şimdiden teşekkür ederim...

 

[asi_kral]

Merhaba
Boş bir açık adlı kitapta boş bir module ekleyin ve içerisine bu kodu ekleyin ve deneyin.

Option Explicit
Sub veri_çek()
Dim DSY As String, YOL As String, STR As Long, BRL As String
Application.ScreenUpdating = False
Range("A2:O" & Rows.Count).ClearContents
STR = Range("A" & Rows.Count).End(xlUp).Row + 1
YOL = ThisWorkbook.Path & "\"
DSY = Dir(YOL & "*.xlsx?")
Do While DSY <> Empty
If DSY <> ActiveWorkbook.Name Then
BRL = "'" & YOL & "[" & DSY & "]YATAY FORMAT'!R6"
Cells(STR, "A") = Application.ExecuteExcel4Macro(BRL & "C1")
Cells(STR, "B") = Application.ExecuteExcel4Macro(BRL & "C2")
Cells(STR, "C") = Application.ExecuteExcel4Macro(BRL & "C3")
Cells(STR, "D") = Application.ExecuteExcel4Macro(BRL & "C4")
Cells(STR, "E") = Application.ExecuteExcel4Macro(BRL & "C5")
Cells(STR, "F") = Application.ExecuteExcel4Macro(BRL & "C6")
Cells(STR, "G") = Application.ExecuteExcel4Macro(BRL & "C7")
Cells(STR, "H") = Application.ExecuteExcel4Macro(BRL & "C8")
Cells(STR, "I") = Application.ExecuteExcel4Macro(BRL & "C9")
Cells(STR, "J") = Application.ExecuteExcel4Macro(BRL & "C10")
Cells(STR, "K") = Application.ExecuteExcel4Macro(BRL & "C11")
Cells(STR, "L") = Application.ExecuteExcel4Macro(BRL & "C12")
Cells(STR, "M") = Application.ExecuteExcel4Macro(BRL & "C13")
Cells(STR, "N") = Application.ExecuteExcel4Macro(BRL & "C14")
Cells(STR, "O") = Application.ExecuteExcel4Macro(BRL & "C15")
STR = STR + 1
End If: DSY = Dir
Loop
Application.ScreenUpdating = True
End Sub