Bilgi alınan dosya adını a sutununa yazdırmak istiyorum

[tahsinanarat]

Option Explicit
Sub dosyaları_birlestir_592()
Dim fso As Object, f As Object, dosya As String, fls As Object
Dim sonsat1 As Long, sonsat2 As Long, sh As Worksheet, liste()
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getfolder(ThisWorkbook.Path & "\YENİ").Files
ThisWorkbook.Activate
ThisWorkbook.Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Range("A:n").ClearContents
For Each fls In f
If fso.GetExtensionName(fls) = "xlsx" Then
If Workbooks.Open(fls).ReadOnly = True Then Workbooks(fls.Name).Close False
For Each sh In Workbooks(fls.Name).Worksheets
sonsat1 = sh.Cells(65536, "A").End(xlUp).Row
If sonsat1 > 4 Then
liste = sh.Range("a2:n" & sonsat1).Value
sonsat2 = ThisWorkbook.Sheets("Sayfa1").Cells(65536, "e").End(xlUp).Row + 1
ThisWorkbook.Sheets("Sayfa1").Range("e" & sonsat2).Resize(UBound(liste), 10) = liste
Erase liste
End If
Next sh
Workbooks(fls.Name).Close False
End If
Next fls
ThisWorkbook.Activate
ThisWorkbook.Sheets("Sayfa1").Select
Application.ScreenUpdating = True
End Sub


Yukarıdaki kodda klasör içinde bulunan dosyaların ilk sayfalarını alt alta birleştirebiliyoruz, birleştirdiğimiz bu dosya isimlerini de a sutununa yazdırmak istediğimizde koda nasıl bir ilave yapmalıyız.

 

[asi_kral]

Merhaba

ThisWorkbook.Sheets("Sayfa1").Range("e" & sonsat2).Resize(UBound(liste), 10) = liste

Bu satırın altına

ThisWorkbook.Sheets("Sayfa1").Range("A" & sonsat2) = fls.Name

Yazarak dener misiniz_?

 

[tahsinanarat]

Sn. Asi Kral ilgilendiğin için çok teşekkür ederim fls den sonra .name yazsam olacakmış. Neyse böyle böyle öğreneceğiz işte. Sağolasınız.

 

[asi_kral]

Sn. Asi Kral ilgilendiğin için çok teşekkür ederim fls den sonra .name yazsam olacakmış. Neyse böyle böyle öğreneceğiz işte. Sağolasınız.

Kolay Gelsin.