Abey parçalamadan alttaki kodu deneyin.Biri yavaş diğeri hızlı çalışması gerek gif ekledim.
2003 versiyonlarda ExecuteExcel4Macro çalışmıyor heralde.
Ekte tüm formatlı dosyalar var örnek olarak.
Dizi olan kod çalışmazsa 1048576 yerine 65536 gibi yapabilirsiniz redimdeki.
Redim preserve olarak yapacaktım lakin veri sayısı 65536 dan fazla olursa çalışmaz diye yapmadım transpose den dolayı.
Kapalı dosya 2003 formatında olursa bulamadığı için Application.DisplayAlerts = False eklemek zounda kaldım.
Benim yavsiyem Sub GetirDizi() 'Hizli kodunu kullanmanız diğeri bazen bulmuyor 2003 olayından dolayı.
Kapalı dosyada zayen öyle format yoksa farketmez.
![[Resim: do.php?img=11157]](https://resim.accesstr.net/do.php?img=11157)
https://resim.accesstr.net/do.php?img=11157
Sub GetirDizi() 'Hizli
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, say As Long
Const sayfa As String = "zarf"
ReDim arr(1 To 1048576, 1 To 3)
With ThisWorkbook.Sheets("Veri")
.Range("B2
" & Rows.Count).Clear
On Error GoTo hata
Application.DisplayAlerts = False
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;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 & "'!"
son = .Cells(Rows.Count, "B").End(3).Row + 1
say = say + 1
arr(say, 1) = "=INDEX(" & yol & "$AB:$AB,21)"
arr(say, 2) = "=INDEX(" & yol & "$AE:$AE,7)"
arr(say, 3) = "=INDEX(" & yol & "$AB:$AB,10)"
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
son = .Cells(Rows.Count, 2).End(3).Row
If son < 2 Then son = 2
.Range("B2" & son).Value = .Range("B2" & son).Value
End If
End With
On Error Resume Next
Application.DisplayAlerts = True
rs.Close: cn.Close: Set fso = Nothing: Set file = Nothing: Erase arr
Exit Sub
hata:
MsgBox "Hatali daosya Altta>>>>>>" & Chr(10) & Chr(10) & "Hata sebebi: " & Err.Description & Chr(10) & Chr(10) & "Dosya adi ve yolu: " & file
Application.DisplayAlerts = True
End Sub
Sub Getir() 'Yavas
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).Clear
On Error GoTo hata
Set cn = New ADODB.Connection
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
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;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 & "'!"
son = .Cells(Rows.Count, "B").End(3).Row + 1
.Range("B" & son).Formula = "=INDEX(" & yol & "$AB:$AB,21)"
.Range("C" & son).Formula = "=INDEX(" & yol & "$AE:$AE,7)"
.Range("D" & son).Formula = "=INDEX(" & yol & "$AB:$AB,10)"
End If
rs.MoveNext
Loop
End If
If cn.State = 1 Then cn.Close
Next
son = .Cells(Rows.Count, "B").End(3).Row
If son > 1 Then .Range("B2" & son).Value = .Range("B2" & son).Value
End With
On Error Resume Next
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
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
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Neuer Ordner.rar
(Dosya Boyutu: 208,46 KB | İndirme Sayısı: 3)
