Klasör İsimlerini Ve Klasör Yollarını Listele

Option Explicit

Sub KlasorIsimleriniVeKlasorYollariniListele()
    '--------------------------------------------------
    'Değişkenler
    '--------------------------------------------------
    Dim objFSO       As Object
    Dim objKlasor    As Object
    Dim objAltKlasor As Object
    Dim i            As Integer
    Dim mesajSonuc   As Variant

    '--------------------------------------------------
    'Hazırlık
    '--------------------------------------------------
    Columns("A:B").Clear

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objKlasor = objFSO.GetFolder("C:UsersvolkankoncaDesktopKK")
    i = 1

    On Error GoTo islemiIptalEt
    Application.EnableCancelKey = xlErrorHandler

    '--------------------------------------------------
    'Onay
    '--------------------------------------------------
    mesajSonuc = _
        MsgBox("Klasörler listelenecek, devam edilsin mi?", _
               VbMsgBoxStyle.vbOKCancel, _
               "UYARI")

    '--------------------------------------------------
    'Listeleme
    '--------------------------------------------------
    If mesajSonuc = VbMsgBoxResult.vbOK Then
        Cells(1, 1) = "KLASÖR ADI"
        Cells(1, 2) = "KLASÖR YOLU"

        For Each objAltKlasor In objKlasor.subfolders
            Cells(i + 1, 1) = objAltKlasor.Name
            Cells(i + 1, 2) = objAltKlasor.Path
            i = i + 1
        Next
    Else
        MsgBox "Listeleme işlemini iptal ettiniz."
    End If

islemiIptalEt:
End Sub