ChisloStrok = ActiveSheet.UsedRange.Rows.Count

Sub FileList()
    Dim V As String
    Dim BrowseFolder As String
     
    'открываем диалоговое окно выбора папки
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выберите папку или диск"
        .Show
        On Error Resume Next
        Err.Clear
        V = .SelectedItems(1)
        If Err.Number <> 0 Then
            MsgBox "Вы ничего не выбрали!"
            Exit Sub
        End If
    End With
    BrowseFolder = CStr(V)
     
    'добавляем лист и выводим на него шапку таблицы
    ActiveWorkbook.Sheets.Add
    With Range("A1:E1")
        .Font.Bold = True
        .Font.Size = 12
    End With
    Range("A1").Value = "Имя файла"
    Range("B1").Value = "Путь"
    Range("C1").Value = "Кол-во"
     
    'вызываем процедуру вывода списка файлов
    'измените True на False, если не нужно выводить файлы из вложенных папок
    ListFilesInFolder BrowseFolder, True
End Sub
 
 
Private Sub ListFilesInFolder(ByVal SourceFolderName As String, 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 = Range("A65536").End(xlUp).Row + 1   'находим первую пустую строку
    'выводим данные по файлу
    'гиперссылка 
    For Each FileItem In SourceFolder.Files
        Cells(r, 1).Formula = FileItem.Name
        Cells(r, 2).Formula = "=HYPERLINK(""" & FileItem.Path & """)"
        Cells(r, 3).Formula = ?
        r = r + 1
        X = SourceFolder.Path
    Next FileItem
     
    'вызываем процедуру повторно для каждой вложенной папки
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If
 
    Columns("A:E").AutoFit
 
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
 
End Sub

    'выводим данные по файлу
    'гиперссылка
    For Each FileItem In SourceFolder.Files
        Cells(r, 1).Formula = FileItem.Name
        Cells(r, 2).Formula = "=HYPERLINK(""" & FileItem.Path & """)"
        Workbooks.Open FileItem.Path
        Cells(r, 3).Formula = Application.WorksheetFunction.CountA(ActiveWorkbook.ActiveSheet.Range("A1:A200"))
        ActiveWorkbook.Close False
        r = r + 1
        X = SourceFolder.Path
    Next FileItem

Sub FileList()
    Dim V As String
    Dim BrowseFolder As String
     
    'открываем диалоговое окно выбора папки
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выберите папку или диск"
        .Show
        On Error Resume Next
        Err.Clear
        V = .SelectedItems(1)
        If Err.Number <> 0 Then
            MsgBox "Вы ничего не выбрали!"
            Exit Sub
        End If
    End With
    BrowseFolder = CStr(V)
     
    &#39;добавляем лист и выводим на него шапку таблицы
    ActiveWorkbook.Sheets.Add
    With Range("A1:E1")
        .Font.Bold = True
        .Font.Size = 12
    End With
    Range("A1").Value = "Имя файла"
    Range("B1").Value = "Путь"
    Range("C1").Value = "Кол-во"
     
    &#39;вызываем процедуру вывода списка файлов
    &#39;измените True на False, если не нужно выводить файлы из вложенных папок
    ListFilesInFolder BrowseFolder, True
End Sub
 
 
Private Sub ListFilesInFolder(ByVal SourceFolderName As String, 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 = Range("A65536").End(xlUp).Row + 1   &#39;находим первую пустую строку
    &#39;выводим данные по файлу
    &#39;гиперссылка 
    For Each FileItem In SourceFolder.Files
        Cells(r, 1).Formula = FileItem.Name
        Cells(r, 2).Formula = "=HYPERLINK(""" & FileItem.Path & """)"
        Cells(r, 3).Formula = ?
        r = r + 1
        X = SourceFolder.Path
    Next FileItem
     
    &#39;вызываем процедуру повторно для каждой вложенной папки
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If
 
    Columns("A:E").AutoFit
 
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
 
End Sub

Private Const baseConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=$1;Extended Properties='Excel 12.0;HDR=NO;IMEX=1';"

Public Function getNotNullRowCountFromFirstColumnOfSheet(ByVal FileName As String) As Long
    Dim pAdoX As Object, pConn As Object
    Dim pTable As Object, pRSet As Object
    Dim sheetTableName As String, vResult As Long
    
    Set pAdoX = CreateObject("ADOX.Catalog")
    Set pConn = CreateObject("ADODB.Connection")
    pConn.Open Replace$(baseConnStr, "$1", FileName)
    pAdoX.ActiveConnection = pConn
    sheetTableName = ""
    vResult = -1
    For Each pTable In pAdoX.Tables
        If Right$(pTable.Name, 1) = "$" Then
            sheetTableName = pTable.Name
            Exit For
        End If
    Next
    If sheetTableName <> "" Then
        Set pRSet = pConn.Execute("Select Count(*) As FCount From [" & sheetTableName & "] Where F1 Is Not Null")
        vResult = pRSet(0).Value
        pRSet.Close
    End If
    pConn.Close
    Set pAdoX = Nothing
    getNotNullRowCountFromFirstColumnOfSheet = vResult
End Function