Private Sub CommandButton1_Click()
Dim i As Long
Dim ArrName As Variant
 Columns( 1 ).ClearContents
    
    With Application.FileSearch
        .NewSearch
        .LookIn = ThisWorkbook.Path & "\"
        .SearchSubFolders = True
        .Filename = "*.xls"
        If .Execute >  0  Then
            For i =  1  To .FoundFiles.Count
                ArrName = Split(.FoundFiles(i), "\")
                ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset( 1 ) = ArrName(UBound(ArrName))
            Next i
        Else
            MsgBox "There were no files found."
        End If
    End With
End Sub

'Выбрать файлы XLS в каталоге и подкаталогах
Private Sub CommandButton4_Click()
  Columns( 3 ).ClearContents
  ВыбратьКаталогПодкаталогиFSO ActiveWorkbook.Path
End Sub

'FileSystemObject - БИБЛИОТЕКА  Microsoft Scripting Runtime
Sub ВыбратьКаталогПодкаталогиFSO(Папка As String)
Dim fso As New FileSystemObject
Dim fold1 As Folder, fold2 As Folder
Dim iFile As File
Dim ArrName As Variant
 
 Set fold1 = fso.GetFolder(Папка)

 For Each fold2 In fold1.SubFolders
   ВыбратьКаталогПодкаталогиFSO (fold2.Path + "\")        'лезем в рекурсию
 Next
  
 For Each iFile In fold1.Files
   If UCase(Right(iFile,  3 )) = "XLS" Then
      ArrName = Split(iFile, "\")
      ActiveSheet.Range("C" & Rows.Count).End(xlUp).Offset( 1 ) = ArrName(UBound(ArrName))
   End If
 Next

End Sub

Private Sub CommandButton5_Click()
 Columns( 2 ).ClearContents
 ВыбратьКаталогПодкаталогиDIR ActiveWorkbook.Path
End Sub

Sub ВыбратьКаталогПодкаталогиDIR(Папка As String)
Dim MyPath As String, iFileName As String, jFileName As String
Dim myArray() As Variant, n As Long, x As Long
 
 MyPath = Папка & "\"
 iFileName = Dir(MyPath, vbDirectory)

 n =  0 
 Do While iFileName <> ""
  If GetAttr(MyPath & iFileName) =  16  Then  ' 48 папка с атрибутом архивная
      If iFileName <> "." And iFileName <> ".." Then
         ReDim Preserve myArray(n) As Variant
         myArray(n) = iFileName
         n = n +  1 
      End If
    Else
      If UCase(Right(iFileName,  3 )) = "XLS" Then
         ActiveSheet.Range("B" & Rows.Count).End(xlUp).Offset( 1 ) = iFileName
      End If
  End If
  
  iFileName = Dir
 Loop


 If n >  0  Then
   For x =  0  To UBound(myArray)
     Debug.Print myArray(x)
     ВыбратьКаталогПодкаталогиDIR (MyPath & myArray(x))
   Next
 End If
 
End Sub

'Выбрать файлы XLS в каталоге и подкаталогах

Private Sub CommandButton4_Click()
Dim fso As New FileSystemObject
  Columns( 3 ).ClearContents
  ВыбратьКаталогПодкаталогиFSO fso.GetFolder(ActiveWorkbook.Path)
End Sub

'FileSystemObject - БИБЛИОТЕКА  Microsoft Scripting Runtime
Sub ВыбратьКаталогПодкаталогиFSO(Папка As Folder)
Dim fso As New FileSystemObject, fold As Folder, iFile As File

 For Each fold In Папка.SubFolders
   ВыбратьКаталогПодкаталогиFSO fold        'лезем в рекурсию
 Next
  
 For Each iFile In Папка.Files
   If UCase(Right(iFile,  3 )) = "XLS" Then
      ActiveSheet.Range("C" & Rows.Count).End(xlUp).Offset( 1 ) = iFile.Name
   End If
 Next

End Sub

Dim fso As New FileSystemObject