Sub FileList()
    Dim arrFolders(), I&, allPath$
    With Worksheets("Information")
        Application.ScreenUpdating = False
        .Range("A1:B" & .UsedRange.Rows.Count).ClearContents
        With .Range("A1:B1")
            .Font.Bold = True
            .Font.Size = 12
            .Value = "ім'я файлу"
        End With
    End With
    allPath = "d:\MyFolders\"   'общая часть пути к папкам
    arrFolders = Array("Folder1", "Folder2")    'массив имен папок для просмотра
    'если целевые папки лежат в разных папках/дисках, то в массив нужно записывать полные пути к ним,
    'или оставить диалог выбора папок
    For I = 0 To UBound(arrFolders)
        'вызов процедуры вывода списка, если надо - true
        ListFilesInFolder allPath & arrFolders(I), I + 1, True
    Next
    Application.ScreenUpdating = True 
End Sub

Private Sub ListFilesInFolder(ByVal SourceFolderName$, N&, ByVal IncludeSubFolders As Boolean)

    Dim FSO As Object
    Dim SourceFolder As Object
    Dim SubFolder As Object
    Dim FileItem As Object
    Dim r As Long
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.getfolder(SourceFolderName)
    
    r = Cells(Rows.Count, N).End(xlUp).Row + 1 'находиим 1ю пустую строку
    'выводим только имя файла
    For Each FileItem In SourceFolder.Files
        Cells(r, N).Formula = FileItem.Name
        r = r + 1
    Next FileItem
    
    'повторная процедура для каждой вложенной папки
    If IncludeSubFolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, N, True
        Next SubFolder
    End If
    
    Columns("A:B").AutoFit
    
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    
End Sub