Dosyayı deneyiniz.
https://resim.accesstr.net/do.php?img=11150
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
Const sayfa As String = "zarf"
With ThisWorkbook.Sheets("Veri")
.Range("B2
" & Rows.Count).ClearContents
Set cn = New ADODB.Connection
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=YES';"
cn.Open
Set rs = cn.OpenSchema(adSchemaTables)
Do Until rs.EOF
If LCase(rs.Fields("TABLE_NAME").Value) = "zarf$" Then
yol = "'" & ThisWorkbook.Path & "\" & "[" & file.Name & "]" & sayfa & "'!R"
son = .Cells(Rows.Count, "B").End(3).Row + 1
.Range("B" & son).Value = Application.ExecuteExcel4Macro(yol & 21 & "C" & 28) '21 satir,28 ise sütun
.Range("C" & son).Value = Application.ExecuteExcel4Macro(yol & 7 & "C" & 31)
.Range("D" & son).Value = Application.ExecuteExcel4Macro(yol & 10 & "C" & 28)
End If
rs.MoveNext
Loop
End If
If cn.State = 1 Then cn.Close
Next
End With
On Error Resume Next
rs.Close: cn.Close: Set fso = Nothing: Set file = Nothing
End Sub
