Barfly
Altın Üye
- Katılım
- 29 Eylül 2007
- Mesajlar
- 136
- Excel Vers. ve Dili
- Microsoft Office Professional Plus 2026 - Türkçe
- Altın Üyelik Bitiş Tarihi
- 26-02-2026
Merhaba,
Aşağıdaki kod ile klasör içerisindeki tüm uygun dosyalardan A:H sütunları arasındaki veriyi alıp rapor dosyasında B sütunundan başlamak üzere alt alta sıralatabiliyorum. Yapmak istediğim ise bu işlem olurken A sütununa da ilgili dosyaların isimleri gelsin. Örneğin Ahmet isimli dosyanın içerisindeki veri 20 satırsa rapor dosyasında bu 20 satırın verisi B:I sütunlarına yazılırken A sütunu da 20 satır boyunca ilgili dosyanın adıyla dolsun. Bu konuda yardımcı olabilecek var mıdır?
Sub Getir()
Set con = VBA.CreateObject("adodb.Connection")
Set cat = CreateObject("ADOX.Catalog")
'Set klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
Cells.ClearContents
Dim bir As Object
Set bir = CreateObject("scripting.filesystemobject")
yol = ThisWorkbook.Path
Set klasor = bir.getfolder(yol)
For Each dosyalar In klasor.Files
If Not dosyalar.Name Like "*xlsm*" Then
If dosyalar.Name Like "*xls*" Then
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
yol & "\" & dosyalar.Name & ";extended properties=""Excel 12.0;hdr=yes"""
cat.ActiveConnection = con
syf = Replace(cat.tables.Item(0).Name, "'", "")
sorgu = "select * from[" & syf & "A1:H]"
Set rs = con.Execute(sorgu)
son = Cells(Rows.Count, "B").End(3).Row + 1
Range("B" & son).CopyFromRecordset rs
con.Close
End If
End If
Next
End Sub
Aşağıdaki kod ile klasör içerisindeki tüm uygun dosyalardan A:H sütunları arasındaki veriyi alıp rapor dosyasında B sütunundan başlamak üzere alt alta sıralatabiliyorum. Yapmak istediğim ise bu işlem olurken A sütununa da ilgili dosyaların isimleri gelsin. Örneğin Ahmet isimli dosyanın içerisindeki veri 20 satırsa rapor dosyasında bu 20 satırın verisi B:I sütunlarına yazılırken A sütunu da 20 satır boyunca ilgili dosyanın adıyla dolsun. Bu konuda yardımcı olabilecek var mıdır?
Sub Getir()
Set con = VBA.CreateObject("adodb.Connection")
Set cat = CreateObject("ADOX.Catalog")
'Set klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
Cells.ClearContents
Dim bir As Object
Set bir = CreateObject("scripting.filesystemobject")
yol = ThisWorkbook.Path
Set klasor = bir.getfolder(yol)
For Each dosyalar In klasor.Files
If Not dosyalar.Name Like "*xlsm*" Then
If dosyalar.Name Like "*xls*" Then
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
yol & "\" & dosyalar.Name & ";extended properties=""Excel 12.0;hdr=yes"""
cat.ActiveConnection = con
syf = Replace(cat.tables.Item(0).Name, "'", "")
sorgu = "select * from[" & syf & "A1:H]"
Set rs = con.Execute(sorgu)
son = Cells(Rows.Count, "B").End(3).Row + 1
Range("B" & son).CopyFromRecordset rs
con.Close
End If
End If
Next
End Sub