При нажатии на кнопку,должны выводиться только папки этой папки и их содержимое

Public Dst As Range
Public BasePath As String
Public FileNumber As Long
 
''''''''''''''''''''
' Функция выбора папки/пути
' Используемые аргументы:
' strTitle - текст, отображаемый над окном выбора папки
' lngRegim - режим отображения окна выбора
'            может комбинироваться путём сложения системных констант
'
'               Const BIF_STATUSTEXT = 4
'               Const BIF_RETURNONLYFSDIRS = 1
'               Const BIF_DONTGOBELOWDOMAIN = 2
'               Const BIF_BROWSEINCLUDEFILES = 16384
'               Const BIF_EDITBOX = 16
'               Const BIF_NEWDIALOGSTYLE = 64
'               Const BIF_NONEWFOLDERBUTTON = 512
'               и др.
'
' В случае нажатия на кнопку "Отмена" ("Cancel") функция возвращает "пустую" строку
'
''''''''''''''''''''
Function strGetAbsoluteFolderPathName(ByVal strTitle As String, ByVal lngRegim As Long) As String
    
    ' Определяем переменные
    Dim objShell As Object
    Dim objFolder As Object
    Dim objFolderItem  As Object
    
    ' Создаём переменную Shell
    Set objShell = CreateObject("Shell.Application")
    
    ' Выводим диалоговое окно выбора папки с нужными параметрами
    Set objFolder = objShell.BrowseForFolder(0, strTitle, lngRegim)
    
    ' Если объект создан не удачно (НЕ выбрали какую-то папку), то
    ' возвращаем пустую строку в качестве результата работы функции...
    If objFolder Is Nothing Then
        strGetAbsoluteFolderPathName = ""
        Exit Function
    End If
    
    ' Получаем объект, у которого "можно спросить" его path
    Set objFolderItem = objFolder.Self
    ' Получаем значение Path
    strGetAbsoluteFolderPathName = objFolderItem.Path
    ' Удаляем все использованные объекты
    Set objFolderItem = Nothing
    Set objFolder = Nothing
    Set objShell = Nothing
End Function
 
Sub ListFiles(DPath, Ur)
Dim FName As String
Dim sd() As String, sdcount As Integer
Dim s As String
sdcount = 0
ReDim sd(0)
 
'и собственно список
    FName = Dir(DPath, vbDirectory)
    Do While FName <> ""
        If FName <> "." And FName <> ".." Then
                'ListFiles DPath & FName & "\"
                sdcount = sdcount + 1
                ReDim Preserve sd(sdcount)
                sd(sdcount) = DPath & FName
        End If
        FName = Dir
    Loop
 
    If (sdcount > 0) Then
        Dim i As Integer
        Dim attr
        For i = 1 To sdcount
            s = Mid(sd(i), Len(BasePath) + 2)
            attr = GetAttr(sd(i))
            If (((attr And vbDirectory) = 0) Or (Ur = 0)) Then
                If (Ur = 0) Then
                    Dst.Value = s
                    Dst.Font.Bold = True
                Else
                    Dst.Value = FileNumber
                    Dst.Offset(0, 1).Value = Mid(s, InStr(s, "\") + 1)
                    FileNumber = FileNumber + 1
                End If
                Set Dst = Dst.Offset(1)
            End If
            If (attr And vbDirectory) = vbDirectory Then
                ListFiles sd(i) & "\", Ur + 1
            End If
        Next
    End If
End Sub
Private Sub CommandButton1_Click()
Dim DPath As String
 
    DPath = strGetAbsoluteFolderPathName("Выберите папку", 4)
    If DPath = "" Then
        Exit Sub
    Else
        BasePath = DPath
        DPath = DPath & "\"
    End If
 
'On Error Resume Next
 
'запрашиваем ячейку
    Set Dst = Application.InputBox(prompt:="Выберите ячейку", Type:=8)
    If Not Dst Is Nothing Then Set Dst = Dst.Cells(1) Else Exit Sub
FileNumber = 1
ListFiles DPath, 0
End Sub