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

Çözüldü #1
Bir klasör içerisindeki dosya isimleri değişken olan ve çalışma kitabı içerisindeki zarf isimli çalışma sayfasındaki hücrelerdeki bilgileri çalışma kitabını açmadan macro yardımı ile acaba veri sayfasına nasıl aldırabilirim? Örnek dosyaya zarf sayfası ekledim. Örnek dosyada sadece veri sayfası olacak. Ama klasör içerisindeki çalışma sayfalarının içerisindeki sadece zarf sayfasından verileri alsın istiyorum. Çalışma kitapları içerisinde zarf sayfasından başka sayfalarda bulunmaktadır. Yardımcı olabilecek arkadaşlara teşekkür ederim.
.rar Klasör İçerisindeki Çalışma Kitaplarından Verileri Alma.rar (Dosya Boyutu: 28,8 KB | İndirme Sayısı: 2)
yyhy, 18-05-2009 tarihinden beri AccessTr.neT üyesidir.
Son Düzenleme: 29/07/2021, 00:47, Düzenleyen: yyhy.
Cevapla
#2
Merhaba.
Dosyayı deneyiniz.


[Resim: do.php?img=11150]
https://resim.accesstr.net/do.php?img=11150

Visual Basic Code
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:D" & 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
.rar Neuer Ordner.rar (Dosya Boyutu: 89,29 KB | İndirme Sayısı: 5)
Cevapla
#3
Sayın feraz bey deneyip bilgi vereceğim. Teşekkür ederim.
yyhy, 18-05-2009 tarihinden beri AccessTr.neT üyesidir.
Cevapla
#4
Sayın Feraz bey dosyayı denedim. 2600 üncü dosyada bir hata aldım. Hata dosya kaynaklı olabilir diye düşünüyorum. Veri aktarma konusunda gayet başarılı emeğinize sağlık teşekkür ederim. Sorunu çözemezsem tekrar başka bir başlık altında sormayı düşünüyorum. İyi akşamlar.
yyhy, 18-05-2009 tarihinden beri AccessTr.neT üyesidir.
Cevapla
#5
(03/08/2021 22:47)yyhy Adlı Kullanıcıdan Alıntı: Sayın Feraz bey dosyayı denedim. 2600 üncü dosyada bir hata aldım. Hata dosya kaynaklı olabilir diye düşünüyorum. Veri aktarma konusunda gayet başarılı emeğinize sağlık teşekkür ederim. Sorunu çözemezsem tekrar başka bir başlık altında sormayı düşünüyorum. İyi akşamlar.
Rica ederim,hata resmi felan varsa inceleyebiliriz.
Cevapla
#6
O kadar fazla dosya varsa alttaki kodlu dosyayı deneyebilirsiniz hızı çalışması lazım.

Visual Basic Code
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
    Dim bulunanSayfaAd As String, say As Long
    Const sayfa As String = "zarf"
    
    
    With ThisWorkbook.Sheets("Veri")
       .Range("B2:D" & Rows.Count).ClearContents
        Set cn = New ADODB.Connection
        
        ReDim arr(1 To Rows.Count - 1, 1 To 3)
        say = 0
        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=NO;Imex=1';"
                cn.Open
                
                Set rs = cn.OpenSchema(adSchemaTables)
                Do Until rs.EOF
                    bulunanSayfaAd = rs.Fields("TABLE_NAME").Value
                    If Right(bulunanSayfaAd, 17) <> "$_xlnm#Print_Area" Then
                        If Mid(LCase(bulunanSayfaAd), 1, Len(LCase(bulunanSayfaAd)) - 1) = sayfa Then
                            yol = "'" & ThisWorkbook.Path & "\" & "[" & file.Name & "]" & sayfa & "'!R"
                            say = say + 1
                            arr(say, 1) = Application.ExecuteExcel4Macro(yol & 21 & "C" & 28) '21 satir,28 ise sütun
                            arr(say, 2) = Application.ExecuteExcel4Macro(yol & 7 & "C" & 31) '7 satir,31 ise sütun
                            arr(say, 3) = Application.ExecuteExcel4Macro(yol & 10 & "C" & 28) '10 satir,28 ise sütun
                        End If
                    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
    End With
     
    On Error Resume Next
    rs.Close: cn.Close: Set fso = Nothing: Set file = Nothing: Erase arr
End Sub
.rar Neuer Ordner.rar (Dosya Boyutu: 88,61 KB | İndirme Sayısı: 2)
Cevapla

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

Yorum yapmak için üye olmanız gerekiyor

ya da
Task