Kapalı Dosyadan veri alma Kod.

[gicimi]

Merhaba,

Paylaşmış olduğum kodun açıklamasını mümkünse yazabilir misiniz_? Birde Dosyalar adlı klasörün içeisindeki bilgileri almaya çalıştığımda kod yer alan rs.Close: con.Close: üzeri sarı renkte oluyor ve veriyi vermiyor.

Yardımcı olur musunuz_?

Sub TABLOLAR()
Dim con As Object, rs As Object, evn As Object, d As Object, k As Object
ThisWorkbook.Sheets("ANASAYFA").Range("A2:L65536").Value = ""
Application.ScreenUpdating = False
Set evn = CreateObject("scripting.filesystemobject")
Set k = evn.getfolder(ThisWorkbook.Path & "\Dosyalar\")
For Each d In k.Files
If VBA.Right(d.Name, 3) = "xls" Or VBA.Right(d.Name, 4) = "xlsx" Then
Set con = CreateObject("adodb.connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
d.Path & ";extended properties=""Excel 12.0;hdr=NO"""
Set rs = con.Execute("select * from [Sayfa1$A2:L65536] WHERE F6 <>'' And F7 <>''")
ThisWorkbook.Sheets("ANASAYFA").Range("A65536").End(3).Offset(1, 0).Cells.CopyFromRecordset rs
'ThisWorkbook.Sheets("KDVVERI").Range("Q65536").End(3).Offset(1, 0) = Left(d.Name, Len(d.Name) - 4)
End If
Next d
Application.ScreenUpdating = True
rs.Close: con.Close:
Set con = Nothing: Set rs = Nothing:  Set evn = Nothing: Set d = Nothing: Set k = Nothing
End Sub

 

[Korhan Ayhan]

Merhaba,

Verdiğiniz kod "Dosyalar" klasörü altındaki excel dosylarının "Sayfa1" isimli sayfalarının "A:L" sütun aralığındaki verileri aktarıyor. Aktarırken F-G sütunlarının boş olmaması koşulunu sorguluyor. Sorgu sonucu oluşan kayıt setini ANASAYFA isimli sayfanızın "A" sütunundaki ilk boş satıra kopyalıyor.

Uyguladığınız ve hata veren dosyaları eklerseniz kontrol edebiliriz.