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 = "Размер"
    Range("D1").Value = "Дата создания"
    Range("E1").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 = FileItem.Path
        Cells(r, 3).Formula = FileItem.Size
        Cells(r, 4).Formula = FileItem.DateCreated
        Cells(r, 5).Formula = FileItem.DateLastModified
        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

Sub Procedure_1()    Const myStart As Long = 2    Dim shActive As Excel.Worksheet, shTarget As Excel.Worksheet
    Dim myFind As Excel.Range
    Dim myLastRow As Long
    Dim myArray As Variant
    
    
    Application.ScreenUpdating = False
    
    Set shActive = Sheets("data")
    Set shTarget = Sheets("Сводная")
    
    Set myFind = shTarget.Columns("B").Find(What:="?", LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
            MatchCase:=False, SearchFormat:=False)
    If myFind Is Nothing Then
       
        myLastRow = myStart
    Else
       
        myLastRow = myFind.Row + 1
    End If
    
    
    shTarget.Rows(myLastRow).Insert Shift:=xlShiftDown, CopyOrigin:=False
    
   
    shActive.Range("B2:AY2").Copy
    
    shTarget.Cells(myLastRow, "B").PasteSpecial Paste:=xlPasteValues
    
    Application.CutCopyMode = False
   
    If myLastRow <> myStart Then
        Set myFind = shTarget.Range("B" & myStart & ":B" & myLastRow - 1).Find( _
            What:=CStr(shActive.Range("B2").Value), _
            LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False)
        If Not myFind Is Nothing Then
           
            myArray = Split(CStr(myFind.Value), " ")
            If IsNumeric(myArray(UBound(myArray))) Then
       
                shTarget.Cells(myLastRow, "B").Value = _
                    shTarget.Cells(myLastRow, "B").Value & " " & myArray(UBound(myArray)) + 1
            Else
               
                myFind.Value = myFind.Value & " " & "1"
                shTarget.Cells(myLastRow, "B").Value = _
                    shTarget.Cells(myLastRow, "B").Value & " " & 2
            End If
        End If
    End If
    
  
    Application.ScreenUpdating = TrueEnd Sub

Sub pdf()
'
' pdf Макрос
''
    Sheets("карта").Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        "Z:\123\" & Range("CB1 ").Value & "_" & Left(Now, 13) & "_" & Mid(Now, 15, 2) & ".pdf" _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, From:=1, To:=2, OpenAfterPublish:=True
End Sub