Re: Klasör İçerisindeki Çalışma Kitaplarından Bilgileri Çalışma Kitabını Açmadan Alma - yyhy - 05/08/2021
Sayın feraz bey son kod çalışmadı işlem yapıyor gibi gözüküyor veri aktarımı hiç yapmadı.
1. vermiş olduğunuz kod çalışıyor. Belli bir yere geldiğinde 2600. evrakta hata veriyordu. 2600 e kadar bir part aldım. 2600 den sonra ise diğer part olarak 4000 e kadar aldım. Hata mesajını da ekliyorum. İşimi gördü ihtiyaca cevap verdi. Teşekkür ederim.
https://resim.accesstr.net/do.php?img=11155
https://resim.accesstr.net/do.php?img=11156
Re: Klasör İçerisindeki Çalışma Kitaplarından Bilgileri Çalışma Kitabını Açmadan Alma - feraz - 05/08/2021
Rica ederim abey.
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
RE: Klasör İçerisindeki Çalışma Kitaplarından Bilgileri Çalışma Kitabını Açmadan Alma - feraz - 05/08/2021
(05/08/2021, 21:05)feraz yazdı: "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & file & ";Extended Properties='Excel 12.0 Xml;HDR=YES';"
Excel 12.0 olan yerdeki 12 yerine 8 yazıp deneyin birde eğer excel2003 formatındaysa ondanda hata verebilir.
RE: Klasör İçerisindeki Çalışma Kitaplarından Bilgileri Çalışma Kitabını Açmadan Alma - feraz - 05/08/2021
2003 versiyonlu bir Excel ekleyip denedim orda hata verdi.
ilgili kodu alttaki gibi değiştinin abey şimdilik yine hata veriyor 2003 için ama devam ediyor.
Tam çözünce eklerim çözümü. koddaki Xml olan yeride sildim kopyala yapıştır yapmıştım.
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & file & ";Extended Properties='Excel 8.0;HDR=YES';"
Re: Klasör İçerisindeki Çalışma Kitaplarından Bilgileri Çalışma Kitabını Açmadan Alma - feraz - 05/08/2021
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.
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
RE: Klasör İçerisindeki Çalışma Kitaplarından Bilgileri Çalışma Kitabını Açmadan Alma - feraz - 06/08/2021
Bu dosyadakilerde aynı işlemi yapıyor.Sadece tek fark sayfa adlarını bulurken gereksizleri almıyor.
Kod biraz uzun diye bunula yapmamıştım.
Birde Excel 2003 formatında varsa dosyalar onları 2007den itibaran olan formatlarla değiştirirseniz daha iyi olur.
Bu dosya dah kullanışlı gibi.
|