Создание отчета в Exel.

Option Explicit
Dim wsh As Worksheet, lRow As Long, lCountry As Long
 
Sub EnumFiles()
    Dim fd As FileDialog, vrtSelectedItem As Variant, sFolder As String, s As String
    
    Set wsh = ThisWorkbook.Worksheets(1)
    lRow = 3
    lCountry = 1
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    
    fd.AllowMultiSelect = False
    
    If fd.Show = -1 Then
        For Each vrtSelectedItem In fd.SelectedItems
            sFolder = vrtSelectedItem
            If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
            Call RecureiveSearch(sFolder, -1)
        Next vrtSelectedItem
    End If
    
    Set fd = Nothing
    Set wsh = Nothing
End Sub
 
Private Sub RecureiveSearch(MyPath As String, ByVal lLevel As Long)
    Dim MyName As String, PS As String, DirList() As String
    Dim i As Long, n As Long, wbk As Workbook, lCounter As Long
    Dim sPath() As String
    
    PS = Application.PathSeparator
    ReDim DirList(0 To 0) As String
    lLevel = lLevel + 1
    lCounter = 0
    
    MyName = Dir(MyPath, vbDirectory)
    Do While MyName <> ""
        If MyName <> "." And MyName <> ".." Then
            n = GetAttr(MyPath & MyName)
            If (n And vbDirectory) = vbDirectory Then
                ReDim Preserve DirList(0 To UBound(DirList) + 1) As String
                DirList(UBound(DirList)) = MyPath & MyName & PS
            Else
                If MyName Like "*.jpg" Or MyName Like "*.tif" Or _
                MyName Like "*.png" Or MyName Like "*.bmp" Or _
                MyName Like "*.gif" Then
                    lCounter = lCounter + 1
                End If
            End If
        End If
        MyName = Dir
    Loop
    
    sPath = Split(MyPath, "\")
    With wsh.Range(wsh.Cells(lRow, 1), wsh.Cells(lRow, 4))
        If lLevel = 1 Then
            .Font.Size = 14
            .Font.Bold = True
            .Font.Italic = False
            .Interior.ColorIndex = 15
            wsh.Cells(lRow, 2).Value = sPath(UBound(sPath) - 1)
            wsh.Cells(lRow, 1).Value = lCountry
            lRow = lRow + 1
            lCountry = lCountry + 1
        ElseIf lLevel = 2 Then
            .Font.Size = 12
            .Font.Bold = False
            .Font.Italic = True
            wsh.Cells(lRow, 2).Value = sPath(UBound(sPath) - 1)
            lRow = lRow + 1
        ElseIf lLevel = 3 Then
            .Font.Size = 10
            .Font.Bold = False
            .Font.Italic = False
            wsh.Cells(lRow, 2).Value = sPath(UBound(sPath) - 1)
            wsh.Cells(lRow, 3).Value = lCounter
            lRow = lRow + 1
        End If
    End With
    
    If UBound(DirList) > 0 Then
        For i = 1 To UBound(DirList)
            RecureiveSearch DirList(i), lLevel
        Next i
    End If
End Sub