Seçilen Klasör Altındaki Dosya Adları

[MrExcelMr]

Merhaba;

Makro yardımıyla klasör seçerek içerisindeki tüm dosyaların isimlerini A sütununa yazdırmak istiyorum. Paylaşmış olduğum kodda seçtiğim klasörün içerisindek klasör var ise o klasörün adını yazıyor. Diğer dosyaları yazmıyor. (.jpg - .pdf- .xls- .rob ... v.s gibi)

Sub bul()
j = 1
Columns("A:A").ClearContents
Dim Klasor As Object
Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(Klasor.items.Item.Path).SubFolders
Cells(j, 1) = f.Path
j = j + 1
Next
MsgBox "işlem tamam"
End Sub

 

[gicimi]

Sub Klasor_Indexle()

On Error Resume Next
    Dim stDir As String
    Dim stFile As String
    Dim R As Range

Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim fldr As FileDialog
Dim klasor_adi As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
fldr.Show
klasor_adi = fldr.SelectedItems.Item(1)
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(klasor_adi)



     ' puts hyperlinks to each of the files in a directory of your choice
     ' into the active sheet starting at the active cell

    Set R = ActiveCell
    stDir = klasor_adi
    stFile = Dir(stDir & "\*.*")
    Do Until stFile = ""
        R.Hyperlinks.Add R, stDir & "\" & stFile, , , stFile
        Set R = R.Offset(1)
        stFile = Dir()
    Loop
    R.CurrentRegion.Sort key1:=R, order1:=xlAscending, Header:=xlNo
    Selection.EntireColumn.AutoFit
End Sub

 

[MrExcelMr]

@gicimi Bey teşekkür ederim. Benim yapmak istediğim aslında şu şekildedir.

Sub kod()
Set klsr = CreateObject("Shell.Application").BrowseforFolder(0, "Klasör seçin", 50, &H0)

İstediğim klasörü seçip içerisindeki dosyları excele yazdırmasını istiyorum.
@Korhan Ayhan @halit3 Bey destek olabilir misiniz.

 

[MrExcelMr]

@Korhan Ayhan Bey destek olabilir misiniz.

 

[konas06]

@gicimi Bey teşekkür ederim. Benim yapmak istediğim aslında şu şekildedir.

Sub kod()
Set klsr = CreateObject("Shell.Application").BrowseforFolder(0, "Klasör seçin", 50, &H0)

İstediğim klasörü seçip içerisindeki dosyları excele yazdırmasını istiyorum.
@Korhan Ayhan @halit3 Bey destek olabilir misiniz.

https://www.excel.web.tr/threads/dosya-ve-klasoer-listeleme.186988/post-1034437

Bu kod size yardımcı olacaktır diye düşünüyorum.

 

[TURKOLOG]

@gicimi Bey teşekkür ederim. Benim yapmak istediğim aslında şu şekildedir.

Sub kod()
Set klsr = CreateObject("Shell.Application").BrowseforFolder(0, "Klasör seçin", 50, &H0)

İstediğim klasörü seçip içerisindeki dosyları excele yazdırmasını istiyorum.
@Korhan Ayhan @halit3 Bey destek olabilir misiniz.

Private Sub CommandButton1_Click()

 

Set shl = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)

Set hdf = shl.BrowseForFolder(0, "Lütfen bir klasör seçiniz!", 0)

If hdf Is Nothing Then

Exit Sub

Else

yol = Worksheets("SABİTLER").[B31]

End If

 

MsgBox "Dosya sayısı: " & FolderFile(yol, "FileCount", True)

End Sub

 

Function FolderFile(klsr As Variant, _

Optional Src As String = "", _

Optional AllFolder As Boolean = False, _

Optional File As String = "*.*") As Variant

Dim dKontrol() As String

Set ds = CreateObject("Scripting.FileSystemObject")

x = 0

SayF = 0

Say = 0

yol = klsr

Application.ScreenUpdating = False

 

If Src = "FolderList" Or Src = "FolderCount" Then

    If ds.GetFolder(yol).subfolders.Count = 0 Then GoTo Son

End If

 

Do

If x = 0 Then

    If Src = "FileList" Or Src = "FileCount" Then GoTo Atla

End If

Tekrar:

If ds.GetFolder(yol).subfolders.Count > 0 Then

    For Each kls In ds.GetFolder(yol).subfolders

        klslst = klslst & "{" & kls

        Say = Say + 1

        If Src = "FolderList" And AllFolder = False Then

            ReDim Preserve dKontrol(1 To Say)

            dKontrol(Say) = kls

            'Cells(Say, 1) = kls

        End If

    Next

If AllFolder = False Then Exit Do

End If

x = x + 1

deg = Split(klslst, "{")

yol = deg(x)

 

If Src = "FolderList" And AllFolder = True Then

    ReDim Preserve dKontrol(1 To x)

    dKontrol(x) = deg(x)

    'Cells(x, 1) = deg(x)

End If

 

Atla:

If Src = "FileList" Or Src = "FileCount" Then

Dosya = Dir$(yol & "\" & File)

Do While Dosya <> ""

SayF = SayF + 1

    If Src = "FileList" Then

        ReDim Preserve dKontrol(1 To SayF)

        dKontrol(SayF) = yol & "\" & Dosya

        'Cells(SayF, 2) = yol & "\" & dosya

    End If

Dosya = Dir$()

Loop

End If

 

If x = 0 And ds.GetFolder(yol).subfolders.Count = 0 Then Exit Do

 

If ds.GetFolder(yol).subfolders.Count > 0 Then GoTo Tekrar

 

Loop While UBound(deg) <> x

Son:

 

If Src = "FileCount" Then

    FolderFile = SayF

ElseIf Src = "FolderCount" Then

    FolderFile = Say

ElseIf Src = "FileList" Then

    If SayF = 0 Then

        ReDim Preserve dKontrol(1 To 1)

        dKontrol(1) = ""

        FolderFile = Application.Transpose(dKontrol)

    Else

        FolderFile = Application.Transpose(dKontrol)

    End If

ElseIf Src = "FolderList" Then

    If x = 0 Then

        ReDim Preserve dKontrol(1 To 1)

        dKontrol(1) = ""

        FolderFile = Application.Transpose(dKontrol)

    Else

        FolderFile = Application.Transpose(dKontrol)

    End If

End If

End Function

 

Private Sub UserForm_Click()

 

End Sub

Bu kodlarla resimdeki gibi sonuca ulaşacaksınız. Gerisi size kalmış. Bittikten sonra dosyanın son halini paylaşırsanız herkes faydalanır. Bilgi paylaştıkça çoğalır.