Kapali dosyadan veri aliminda dosya adı

[umit1907]

Merhabalar,

Ekteki gibi bir kod satırıyla kapalı dosyalardaki verileri çekebiliyorum yalnız çekilen verilerin karşısına örneğin "M" sutununada çcekilen dosya ismini yazdırmak istiyorum. Yardımcı olabilirmisiniz. Tüm verilerin karşısına yazılacaktır.


Private Sub CommandButton2_Click()

On Error Resume Next
Dim con As Object, evn As Object, yol As String
Sayfa2.Range("a2:z65536").ClearContents

Set con = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
Set evn = CreateObject("scripting.filesystemobject")
Set klasor = evn.getfolder(ThisWorkbook.Path & "\Siparişler")
For Each D In klasor.Files
If D.Name <> ThisWorkbook.Name Then
If VBA.Right(D.Name, 4) = "xlsx" Or VBA.Right(D.Name, 3) = "xls" Then


con.Open " provider=microsoft.ace.oledb.12.0;data source=" & _
D.Path & ";extended properties=""excel 12.0;hdr=no"""
sorgu = "select f2,f3,f14,f15,f16,f17,f18 from [Birleştirilmiş$a6:r300]"
rs.Open sorgu, con, 1, 1
Sayfa2.Range("b65536").End(3)(2, 1).CopyFromRecordset rs

rs.Close
con.Close

End If
End If
Next D

Set rs = Nothing: Set con = Nothing
Set evn = Nothing: Set klasor = Nothing: D = vbNullString
End Sub

 

[veyselemre]

Örnek olmadığı için denenmemiştir.

sorgu = "select f2,f3,f14,f15,f16,f17,f18,,,,,'" & d.Name & "' from [Birleştirilmiş$a6:r300]"

 

[umit1907]

Merhaba Veysel Bey bu şekilde olmadı ama örnek bir dosya ekliyorum. Yardımlarınız için teşekkürler.

 

[Haluk]

'......
'...
'..
Sayfa2.Range("b65536").End(3)(2, 0) = d.Name
sorgu = "select f2,f3,f14,f15,f16,f17,f18 from [Birleştirilmiş$a6:r300]"
'....
'...
'..

 

[umit1907]

Teşekkürler Hakuk Bey Elinize sağlık oldu.

 

[Orion1]

Alternatif.

sorgu = "select '" & Left(D.Name, Len(D.Name) - 4) & "',f2,f3,f14,f15,f16,f17,f18 from [Birleştirilmiş$a6:r300]"
rs.Open sorgu, con, 1, 1
Sayfa2.Range("A65536").End(3)(2, 1).CopyFromRecordset rs

 

[umit1907]

Sağolasın Abi