Dosya adlarını yazdırma

[mersilen]

Merhabalar
Bir klasörde bulunan dosya isimlerini performans excel dosyasına makro kodlarını çalıştırarak yazdırıyorum.Bir öncekilerini silip yada sayfayı temizleyip yazdırmayı A10 satırından başlatmak için kodlarda nasıl bir düzenleme yapmamız lazım.

Not:Kodu arka arkaya çalıştırdığımda ms box da gelen mesajdaki sayıda yanlış oluyor.

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Dim baslangıc As Variant

Sub bul()
sat1 = Cells(Rows.Count, "A").End(3).Row - 1

Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
msg = "Lütfen bir klasör seçiniz."
bInfo.pidlRoot = 0&
If IsMissing(msg) Then
bInfo.lpszTitle = "Lütfen bir klasör seçiniz."
Else
bInfo.lpszTitle = msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))

Call Liste(Left(Path, pos - 1), "")

Else
MsgBox "işlemi iptal ettiniz."
Exit Sub
End If


Application.DisplayAlerts = False
Range("A1").Select

sat = Cells(Rows.Count, "A").End(3).Row - 1
MsgBox sat - sat1 & " adet dosya bulundu işlem tamam"

End Sub

Private Sub Liste(Klasor As String, Uzanti As String)
Dim Hedef As Object, Kaynak As Object, Dosya As String, sat As Long
Set Hedef = CreateObject("Scripting.FileSystemObject").getfolder(Klasor).SubFolders
Dim wb As Workbook
sil = Cells(Rows.Count, "A").End(3).Row + 1: Rows("2:" & sil + 1).Select: Selection.Delete Shift:=xlUp

Dosya = Dir(Klasor & "\*.**" & Uzanti)
Application.ScreenUpdating = False
While Dosya <> ""

DoEvents
Application.DisplayAlerts = False
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
'sat = [a65000].End(3).Row + 1
sat = Cells(Rows.Count, "A").End(3).Row + 1


'Cells(sat, "A").Value = Klasor & "\" & Dosya
Cells(sat, "A").Value = WorksheetFunction.Substitute(Dosya, ".xlsx", "")

End If
Dosya = Dir
Wend

On Error GoTo sonraki
For Each Kaynak In Hedef
Call Liste(Kaynak.Path, "")
sonraki:
Next

Set Hedef = Nothing
End Sub

 

[Ömer]

Merhaba,

Listeleyen kodları aşağıdaki gibi değiştirerek deneyiniz.

[COLOR=black]Private Sub Liste(Klasor As String, Uzanti As String)[/COLOR]
Dim Hedef As Object, Kaynak As Object, Dosya As String, sat As Long
Set Hedef = CreateObject("Scripting.FileSystemObject").getfolder(Klasor).SubFolders
Dim wb As Workbook
[COLOR=red]Range("A10:A" & Rows.Count).ClearContents[/COLOR]
Dosya = Dir(Klasor & "\*.**" & Uzanti)
Application.ScreenUpdating = False
[COLOR=red]sat = 10 '[/COLOR]Cells(Rows.Count, "A").End(3).Row + 1
While Dosya <> ""
DoEvents
Application.DisplayAlerts = False
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
'sat = [a65000].End(3).Row + 1
'Cells(sat, "A").Value = Klasor & "\" & Dosya
Cells(sat, "A").Value = WorksheetFunction.Substitute(Dosya, ".xlsx", "")
[COLOR=red]sat = sat + 1[/COLOR]
End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each Kaynak In Hedef
Call Liste(Kaynak.Path, "")
sonraki:
Next
Set Hedef = Nothing
End Sub

.

 

[mersilen]

Ömer bey teşekkür ederim.