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.
![[Resim: do.php?img=11150]](https://resim.accesstr.net/do.php?img=11150)
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