Skip to main content

AccessTr.neT


Klasör İçerisindeki Çalışma Kitaplarından Bilgileri Çalışma Kitabını Açmadan Alma

Klasör İçerisindeki Çalışma Kitaplarından Bilgileri Çalışma Kitabını Açmadan Alma

#11
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

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("B2Lol" & 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("B2Lol" & son).Value = .Range("B2Lol" & 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("B2Lol" & 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("B2Lol" & son).Value = .Range("B2Lol" & 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
.rar Neuer Ordner.rar (Dosya Boyutu: 208,46 KB | İndirme Sayısı: 3)
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da

Bu Konudaki Yorumlar
Re: Klasör İçerisindeki Çalışma Kitaplarından Bilgileri Çalışma Kitabını Açmadan Alma - Yazar: feraz - 05/08/2021, 23:01
Task