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.

Merhaba.
Dosyayı deneyiniz.



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

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';"

                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

Sayın feraz bey deneyip bilgi vereceğim. Teşekkür ederim.

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.

(03/08/2021, 22:47)yyhy yazdı: 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.

O kadar fazla dosya varsa alttaki kodlu dosyayı deneyebilirsiniz hızı çalışması lazım.

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" & 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