Bir klasördeki dosyalara hyperlink yaratma

[danersin]

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.

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

Teşekkürler.

 

[ALPEN]

ActiveSheet.Hyperlinks.Add Anchor:=Cells(ThisRow, f), Address:=Dosyam, _
TextToDisplay:=DosyaAdi

satırını

ActiveSheet.Hyperlinks.Add Anchor:=Cells(ThisRow, f), Address:=Dosyam, _
TextToDisplay:=left(DosyaAdi, len(dosyaadi) - 4)

olarak değiştirin

 

[danersin]

Çok teşekkürler Alpen,

Benimki biraz derede boğulmak olmuş, excel fonksiyonları ile her gün yaptığım(ız) işlemi makro ile yapar iken neden ise daha karışık yöntem düşünmüştüm. Dosya eklerinin uzantılarının hep 3 karakter olacağını düşünemedim.

 

[ALPEN]

bazen kafa karışıyor.

 

[tahsinanarat]

1.mesajdaki kodu çalıştıramadım, elinde olan varsa çalışır vaziyette dosyayı ekleyebilr mi?

 

[tahsinanarat]

1.mesajdaki kod lazım oldu yine çalıştıramadım, yardımcı olabilirmisiniz.