Vba excel количество файлов в папке

Этот макрос выводит информацию о папке — например, её размер, и количество файлов в ней:

Sub ПодсчётКоличестваФайловВПапке()
    ' задаём папку
    FolderPath = "C:Documents and SettingsAdminРабочий стол"
 
    ' получаем характеристики папки
    Set FSO = CreateObject("Scripting.FileSystemObject")
    КоличествоФайловВПапкеБезУчётаПодпапок = FSO.GetFolder(FolderPath).Files.Count
    КоличествоПодпапок = FSO.GetFolder(FolderPath).SubFolders.Count
    РазмерПапкиВБайтах = FSO.GetFolder(FolderPath).Size
 
    ' подсчитываем количество файлов с учётом файлов в подпапках
    КоличествоФайловВПапкеСУчётомПодпапок = FilesCount(FolderPath)
 
    Debug.Print "В папке найдено " & КоличествоФайловВПапкеБезУчётаПодпапок & " файлов и " & _
                КоличествоПодпапок & " подпапок. Всего файлов: " & КоличествоФайловВПапкеСУчётомПодпапок
    Debug.Print "Папка занимает на диске " & РазмерПапкиВБайтах & " байтов (" & _
                FileOrFolderSize(РазмерПапкиВБайтах) & ")"
End Sub

Результат работы кода (в окне Immediate):

В папке найдено 186 файлов и 31 подпапок. Всего файлов: 4216
Папка занимает на диске 193158100 байтов (184 Мб)

Если же вам надо вывести список файлов на лист Excel — смотрите функцию FilenamesCollection:
http://excelvba.ru/code/FilenamesCollection

Код необходимых функций для подсчёта файлов:

Function FilesCount(ByVal FolderPath As String, Optional ByVal SearchDeep As Long = 999) As Long
    ' Получает в качестве параметра путь к папке FolderPath,
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает количество найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    FilesCount = GetFilesCountUsingFSO(FolderPath, FSO, SearchDeep)       ' подсчёт файлов
    Set FSO = Nothing
End Function
 
Function GetFilesCountUsingFSO(ByVal FolderPath As String, ByRef FSO, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    'On Error Resume Next:
    Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке
        GetFilesCountUsingFSO = curfold.Files.Count
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    ' перебираем все подпапки в папке FolderPath
                GetFilesCountUsingFSO = GetFilesCountUsingFSO + GetFilesCountUsingFSO(sfol.Path, FSO, SearchDeep)
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function

Для вывода понятной (отформатированной) информации об объёме папки или файла используется функция FileOrFolderSize:

Function FileOrFolderSize(ByVal s) As String
    Size = Fix(Val(s)):    ' If s = "" Then FileOrFolderSize = "<нет доступа>"
    Select Case Size
        Case Is < 1000: FileOrFolderSize = Size & " байт"
        Case Is < 10000: FileOrFolderSize = FormatNumber(Size / 1024, 1) & " Кб"
        Case Is < 1000000: FileOrFolderSize = FormatNumber(Size  1024, 0) & " Кб"
        Case Is < 10000000: FileOrFolderSize = FormatNumber(Size / 1024 / 1024, 1) & " Mб"
        Case Is < 1000000000: FileOrFolderSize = FormatNumber(Size / 1024 / 1024, 0) & " Мб"
        Case Else: FileOrFolderSize = FormatNumber(Size / 1024 / 1024 / 1024, 1) & " Гб"
    End Select
End Function

I want to know how many files in the folders and their subfolders. I search here and some google pages but I didn’t find what I’m looking for. The closest thing I’ve been looking for is this.

    Sub MainList()
    'Updateby Extendoffice
    Set folder = Application.FileDialog(msoFileDialogFolderPicker)
    If folder.Show <> -1 Then Exit Sub
    xDir = folder.SelectedItems(1)
    Call ListFilesInFolder(xDir, True)
    End Sub

    Sub ListFilesInFolder(ByVal xFolderName As String, ByVal xIsSubfolders As Boolean)
    Dim xFileSystemObject As Object
    Dim xFolder As Object
    Dim xSubFolder As Object
    Dim xFile As Object
    Dim rowIndex As Long
    Set xFileSystemObject = CreateObject("Scripting.FileSystemObject")
    Set xFolder = xFileSystemObject.GetFolder(xFolderName)
    rowIndex = Application.ActiveSheet.Range("A65536").End(xlUp).Row + 1
    For Each xFile In xFolder.Files
      Application.ActiveSheet.Cells(rowIndex, 1).Formula = xFile.Name
      rowIndex = rowIndex + 1
    Next xFile
    If xIsSubfolders Then
      For Each xSubFolder In xFolder.SubFolders
        ListFilesInFolder xSubFolder.Path, True
      Next xSubFolder
    End If
    Set xFile = Nothing
    Set xFolder = Nothing
    Set xFileSystemObject = Nothing
    End Sub

    Function GetFileOwner(ByVal xPath As String, ByVal xName As String)
    Dim xFolder As Object
    Dim xFolderItem As Object
    Dim xShell As Object
    xName = StrConv(xName, vbUnicode)
    xPath = StrConv(xPath, vbUnicode)
    Set xShell = CreateObject("Shell.Application")
    Set xFolder = xShell.Namespace(StrConv(xPath, vbFromUnicode))
    If Not xFolder Is Nothing Then
      Set xFolderItem = xFolder.ParseName(StrConv(xName, vbFromUnicode))
    End If
    If Not xFolderItem Is Nothing Then
      GetFileOwner = xFolder.GetDetailsOf(xFolderItem, 8)
    Else
      GetFileOwner = ""
    End If
    Set xShell = Nothing
    Set xFolder = Nothing
    Set xFolderItem = Nothing
    End Function

But it gives me the files list. I want to know how many file is there each folder? Do you have a any suggestion?

EDİT:

-MainFolder
  -- SubFolder1 -- Has .. file
  -- SubFolder2 -- Has .. file
     --SubFolder2 subfolder -- Has .. file
     --SubFolder2 subfolder1 -- Has .. file
     --SubFolder2 subfolder2 -- Has .. file
  -- SubFolder3 -- Has .. file
.
.
.

I want to something like this structure in excel worksheet.

Count Files in Folder From a List of File Paths

• The given list of file paths is in A2:A20.
• The result of the 1st procedure, CountFilesPerFolder, is in B2:B20.
• The result of the 2nd procedure, ListFilesCountPerFolder, is in E2:F8.

The Excel Formula to Get the Folder Paths (Evaluate)

=LEFT(A2,FIND("*",SUBSTITUTE(A2,"","*",LEN(A2)-LEN(SUBSTITUTE(A2,"",""))))-1)

The Code

Option Explicit


Sub CountFilesPerFolder()
    
    ' Source
    Const sCol As String = "A"
    ' Destination
    Const dCol As String = "B"
    ' Both
    Const fRow As Long = 2
    
    ' Reference the worksheet.
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    ' Reference the one-column range containing the file paths by using
    ' the End property to calculate the last row.
    Dim slRow As Long: slRow = ws.Cells(ws.Rows.Count, sCol).End(xlUp).Row
    Dim rCount As Long: rCount = slRow - fRow + 1
    If rCount < 1 Then Exit Sub ' column range is empty
    Dim srg As Range: Set srg = ws.Cells(fRow, sCol).Resize(rCount)
    Dim sAddress As String: sAddress = srg.Address
    
    ' Write the folder paths to an array by using the Evaluate method.
    Dim Data As Variant
    Data = ws.Evaluate("LEFT(" & sAddress & ",FIND(""*"",SUBSTITUTE(" _
        & sAddress & ","""",""*"",LEN(" & sAddress & ")-LEN(SUBSTITUTE(" _
        & sAddress & ","""",""""))))-1)")
        
    ' Write the folder paths from the array to the keys of a dictionary
    ' using its items to count the files.
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    Dim Key As Variant
    Dim r As Long
    For r = 1 To rCount
        Key = Data(r, 1)
        If Not IsError(Key) Then
            If Len(Key) > 0 Then
                dict(Key) = dict(Key) + 1
            End If
        End If
    Next r
    If dict.Count = 0 Then Exit Sub ' only blanks and error values
    
    ' Write the files count from the items of the dictionary
    ' to the array (overwriting the folder paths).
    For r = 1 To rCount
        Key = Data(r, 1)
        If dict.Exists(Key) Then
            Data(r, 1) = dict(Key)
        Else
            Data(r, 1) = Empty
        End If
    Next r
    
    ' Write the files count from the array to the destination one-column range
    ' and clear the contents below.
    With srg.EntireRow.Columns(dCol)
        .Resize(rCount).Value = Data
        .Resize(ws.Rows.Count - .Row - rCount + 1).Offset(rCount).ClearContents
    End With
    
End Sub


Sub ListFilesCountPerFolder()
    
    ' Source
    Const sCol As String = "A"
    ' Destination
    Const dCol As String = "E"
    ' Both
    Const fRow As Long = 2
    
    ' Reference the worksheet.
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    ' Reference the one-column range containing the file paths by using
    ' the End property to calculate the last row.
    Dim slRow As Long: slRow = ws.Cells(ws.Rows.Count, sCol).End(xlUp).Row
    Dim rCount As Long: rCount = slRow - fRow + 1
    If rCount < 1 Then Exit Sub ' column range is empty
    Dim srg As Range: Set srg = ws.Cells(fRow, sCol).Resize(rCount)
    Dim sAddress As String: sAddress = srg.Address
    
    ' Write the folder paths to an array by using the Evaluate method.
    Dim Data As Variant
    Data = ws.Evaluate("LEFT(" & sAddress & ",FIND(""*"",SUBSTITUTE(" _
        & sAddress & ","""",""*"",LEN(" & sAddress & ")-LEN(SUBSTITUTE(" _
        & sAddress & ","""",""""))))-1)")
        
    ' Write the folder paths from the array to the keys of a dictionary
    ' using its items to count the files.
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    Dim Key As Variant
    Dim r As Long
    For r = 1 To rCount
        Key = Data(r, 1)
        If Not IsError(Key) Then
            If Len(Key) > 0 Then
                dict(Key) = dict(Key) + 1
            End If
        End If
    Next r
    rCount = dict.Count
    If rCount = 0 Then Exit Sub ' only blanks and error values
    
    ' Resize the array according to the number of key-value pairs
    ' of the dictionary and write the data from the dictionary to the array.
    ReDim Data(1 To rCount, 1 To 2)
    r = 0
    For Each Key In dict.Keys
        r = r + 1: Data(r, 1) = Key: Data(r, 2) = dict(Key)
    Next Key
    
    ' Write the data from the array to the destination two-column range
    ' and clear the contents below.
    With srg.EntireRow.Columns(dCol).Resize(, 2)
        .Resize(rCount).Value = Data
        .Resize(ws.Rows.Count - .Row - rCount + 1).Offset(rCount).ClearContents
    End With
    
End Sub