Hata resimlerini foruma ekledim.
ilk mesajdaki kod hata mesajı eklettim kodu çalıştırırsanız hata verirse sebebini ve dosya yolu ve adı olarak verir.
Birde son kod bende çalışmıştı.Kod yavaş değilse sorun yok zaten.
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';"
On Error GoTo hata
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
Exit Sub
hata:
MsgBox "Hatali daosya Altta>>>>>>" & Chr(10) & Chr(10) & "Hata sebebi: " & Err.Description & Chr(10) & Chr(10) & "Dosya adi ve yolu: " & file
End Sub