Aşağıdaki kod bir klasörün altında alt klasörler var ve bu alt klasörlerin isimleri sütun başlıklarımı oluşturuyor. Her sütun başlığının altına o klasörün içindeki dosyaları listeliyor, her dosyaya hyperlink yaratıyor ve alfabetik olarak sıralıyor. Kod bu hali ile düzgün çalışıyor ve umarım birilerinin işine yarar. Sorum ise dosya uzantılarını yazdırmadan aynı işi nasıl yapabilirim.
Teşekkürler.
Kod:
Sub DosyalaraLink()
Application.ScreenUpdating = False
Dim DosyaAdi As String
Dim ThisRow As Long
Dim KlasorunYeri As String
Range("b6:h500").ClearContents
f = 2 'sütun başlıkları
Do Until Worksheets("TALIMAT").Cells(5, f) = ""
ThisRow = 5 'Bu satırdan itibaren yazmaya başlar
KY1 = Worksheets("TALIMAT").Cells(3, 1)
KY2 = Worksheets("TALIMAT").Cells(4, 1)
KY3 = Worksheets("TALIMAT").Cells(5, f) & "\"
KY = KY1 & KY2 & "\" & KY3 'Hücrelerden klasörün yerini oluşturuyor.
KlasorunYeri = KY & "*.*"
DosyaAdi = Dir(KlasorunYeri)
Do Until DosyaAdi = ""
'link koyma
ThisRow = ThisRow + 1
Dosyam = KY & DosyaAdi
ActiveSheet.Hyperlinks.Add Anchor:=Cells(ThisRow, f), Address:=Dosyam, _
TextToDisplay:=DosyaAdi
DosyaAdi = Dir
'sıralama için
Cells(5, f).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Cells(5, f), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Loop
f = f + 1
Loop
Application.ScreenUpdating = True
End Sub