dosya yolu

[oydemir]

iyi günler elimde klasör içini listeleyen ve link veren makro var. Fakat C:\Users\aa\Downloads klasörünün içini listeliyor. Bu kotlarda nasıl bir değişiklik yaparak istediğim klasör içini listeliye bilirim. Teşekkürler

Sub InsertFilesInFolder()
Dim sPath As String, Value As String
Dim WS As Worksheet
Set WS = Sheets.Add
sPath = ActiveWorkbook.Path & "\"
Value = Dir(sPath, &H1F)
WS.Range("A1") = "Filename"
Set StartCell = WS.Range("A2")
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If GetAttr(sPath & Value) = 16 Then
Else
If Value <> ActiveWorkbook.Name And Value <> "~$" & ActiveWorkbook.Name Then
StartCell.Hyperlinks.Add Anchor:=StartCell, Address:= _
Value, TextToDisplay:=Value
Set StartCell = StartCell.Offset(1, 0)
End If
End If
End If
Value = Dir
Loop
End Sub

 

[RBozkurt]

Deneyiniz,

Sub KlasorIcerikListele()
    Dim KlasorYolu As String, Value As String
    Dim WS As Worksheet
    Dim Baslangic As Range
    Dim fd As FileDialog
    Dim SayfaCikis As Boolean
    Dim SayfaAdi As String
    Dim sheet As Worksheet

    SayfaAdi = "Dosya Listesi"
    SayfaCikis = False

    For Each sheet In ThisWorkbook.Sheets
        If sheet.Name = SayfaAdi Then
            SayfaCikis = True
            Set WS = sheet
            Exit For
        End If
    Next sheet

    If Not SayfaCikis Then
        Set WS = Sheets.Add
        WS.Name = SayfaAdi
    Else
        WS.Cells.Clear
    End If

    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "Klasör Seçin"
        .AllowMultiSelect = False
        If .Show = -1 Then
            KlasorYolu = .SelectedItems(1) & "\"
        Else
            MsgBox "Bir klasör seçmediniz. İşlem iptal edildi.", vbExclamation
            Exit Sub
        End If
    End With

    WS.Range("A1") = "Dosya Adı"
    Set Baslangic = WS.Range("A2")

    Value = Dir(KlasorYolu, &H1F)
    Do Until Value = ""
        If Value <> "." And Value <> ".." Then
            If GetAttr(KlasorYolu & Value) = 16 Then
            Else
                If Value <> ActiveWorkbook.Name And Value <> "~$" & ActiveWorkbook.Name Then
                    Baslangic.Hyperlinks.Add Anchor:=Baslangic, Address:= _
                    KlasorYolu & Value, TextToDisplay:=Value
                    Set Baslangic = Baslangic.Offset(1, 0)
                End If
            End If
        End If
        Value = Dir
    Loop

    MsgBox "Dosya listesi başarıyla oluşturuldu.", vbInformation
End Sub

 

[oydemir]

teşekkürler eliniz sağlık

 

[RBozkurt]

teşekkürler eliniz sağlık

Kolay gelsin.

 

[oydemir]

sizede