Sub Getir()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim fso As New Scripting.FileSystemObject
Dim file As file, yol As String, son As Long
Dim bulunanSayfaAd As String, say As Long
Const sayfa As String = "zarf"
With ThisWorkbook.Sheets("Veri")
.Range("B2" & Rows.Count).ClearContents
Set cn = New ADODB.Connection
ReDim arr(1 To Rows.Count - 1, 1 To 3)
say = 0
For Each file In fso.GetFolder(ThisWorkbook.Path).Files
If fso.GetBaseName(ThisWorkbook.Name) <> fso.GetBaseName(file) And Left(file.Name, 2) <> "~$" And fso.GetExtensionName(file) Like "xls*" Then
cn.ConnectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & file & ";Extended Properties='Excel 12.0 Xml;HDR=NO;Imex=1';"
cn.Open
Set rs = cn.OpenSchema(adSchemaTables)
Do Until rs.EOF
bulunanSayfaAd = rs.Fields("TABLE_NAME").Value
If Right(bulunanSayfaAd, 17) <> "$_xlnm#Print_Area" Then
If Mid(LCase(bulunanSayfaAd), 1, Len(LCase(bulunanSayfaAd)) - 1) = sayfa Then
yol = "'" & ThisWorkbook.Path & "\" & "[" & file.Name & "]" & sayfa & "'!R"
say = say + 1
arr(say, 1) = Application.ExecuteExcel4Macro(yol & 21 & "C" & 28) '21 satir,28 ise sütun
arr(say, 2) = Application.ExecuteExcel4Macro(yol & 7 & "C" & 31) '7 satir,31 ise sütun
arr(say, 3) = Application.ExecuteExcel4Macro(yol & 10 & "C" & 28) '10 satir,28 ise sütun
End If
End If
rs.MoveNext
Loop
End If
If cn.State = 1 Then cn.Close
Next
If say > 0 Then .Range("B2").Resize(say, 3).Value = arr
End With
On Error Resume Next
rs.Close: cn.Close: Set fso = Nothing: Set file = Nothing: Erase arr
End Sub
O kadar fazla dosya varsa alttaki kodlu dosyayı deneyebilirsiniz hızı çalışması lazım.