Dosya adlarını almak

[sert_unsuz]

Merhaba.
Ekte bulunan klasördeki excel isimlerinin veri dosyasında A sutununa yazdırmak istiyorum.
Teşekkür ederim.

 

[Necdet]

Merhaba,

Bir zamanlar kendim için yaptığım dosyayı ekliyorum. Hem dosyaları A sütununa getirir hem link verir, gerekirse siz link işlemini kaldırabilirsiniz.

Not : 2007 Sürümünde Çalışmadığını Gördüm

Sub PathBul_DosyaGetir_Linkekle()
On Error GoTo Son
Application.ScreenUpdating = False
Yol = ""
Set objFolder = CreateObject("Shell.Application").BrowseForFolder(0, "DOSYO YOLUNU BULUNUZ !", 0)
    If Not objFolder Is Nothing Then
        Yol = objFolder.Items.Item.Path
    End If
    
If Yol = "" Then Exit Sub
[B1] = Yol
YolUzunluk = Len(Yol)
Range("A2:A1000").ClearContents
Set Dosyalar = Application.FileSearch
With Dosyalar
    .LookIn = Yol
    .SearchSubFolders = False
    .Filename = "*.xls"
    If .Execute() > 0 Then
        Buldum = 1
        Adet = .FoundFiles.Count
        For i = 1 To Adet
            Cells(i + 1, 1) = Right(.FoundFiles(i), Len(.FoundFiles(i)) - YolUzunluk - 1)
        Next i
    End If
End With
    Columns("A:A").Columns.AutoFit
'----------------------------------- Linkleri Vermeye Başla Bakem --------------
For i = 2 To [A65536].End(3).Row
    Range("A" & i).Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Yol & "\" & Cells(i, "A")
'        Yol & Cells(i, "A") & ".xls"
Next i
    Application.CommandBars("Web").Visible = False
Son:
End Sub

 

[sert_unsuz]

Hocam çok teşekkür ederim.
Eline sağlık tam istediğim gibi olmuş.

 

[Necdet]

Güle güle kullanınız.