Dim objFSO As FileSystemObject
Dim objFile As File
Dim intNum As Integer 'Количество файлов
Dim strNameFile As String 'Имя файла
Dim strDataSozdania As String ' Дата создания
Dim strObemzSozd As String ' Объем созданного файла
Dim strDataRedakt As String 'Дата редактирования
Dim strObemRedakt As String 'Объем редактированного файла
Dim i As Integer, iP As Integer 'Переменные для цикла
Dim r As Integer, rP As Integer 'Переменные для цикла
'Dim nI As Integer, nDirectory As Integer
Dim sFileName As String 'Имя файла
Dim sStartPath As String 'Начальный каталог


Private Sub CommandButton1_Click()
    If ActiveWorkbook.Application.Version > "11.0" Then
        MsgBox "Для работы программы должен быть установлен Microsoft Office 2003 или меньше."
        Exit Sub
    End If
    Set objFSO = New FileSystemObject
    'Путь к файлу
    sStartPath = Application.ActiveWorkbook.Path & "\"
    Call PrintTextToTabl
End Sub

Sub PrintFile()
    Range("A" & iP).Select
    ActiveCell.FormulaR1C1 = rP & "." 
    Range("C" & iP).Select
    ActiveCell.FormulaR1C1 = sFileName 
    Range("D" & iP).Select
    ActiveCell.FormulaR1C1 = strDataSozdania 
    If strDataSozdania <> strDataRedakt Then
        Range("E" & iP).Select
        ActiveCell.FormulaR1C1 = strObemzSozd 
        Range("F" & iP).Select
        ActiveCell.FormulaR1C1 = strDataRedakt 
        Range("G" & iP).Select
        ActiveCell.FormulaR1C1 = strObemRedakt 
    Else
        Range("E" & iP).Select
        ActiveCell.FormulaR1C1 = strObemzSozd 
    End If
 
     Range("A" & iP & ":I" & iP).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
    End With
iP = iP +  1 
rP = rP +  1 
End Sub


Sub PrintTextToTabl()
With Application.FileSearch
  .LookIn = sStartPath
  .SearchSubFolders = True
  .FileType = msoFileTypeAllFiles
If .Execute >  0  Then
    If MsgBox("Продолжить заполнение внутренней описи идалив имеющиеся данные?", vbQuestion + vbDefaultButton2 + vbYesNo, "Всего найденных файлов : " & .FoundFiles.Count & ".") = vbYes Then
    'Ощищаем таблицу
    Range("A7:I3500").Select
    Selection.ClearContents
    Range("A7:I3500").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
            iP =  7 
            rP =  1 
        For i =  1  To .FoundFiles.Count
            Set objFile = objFSO.GetFile(.FoundFiles(i))
            ' вывод имен файлов
               sFileName = objFile.Name
                If sFileName <> "Внутренняя опись.xls" Then
                    strDataSozdania = Format(objFile.DateCreated, "DD.MM.YY")
                    strObemzSozd = objFile.Size
                    strDataRedakt = Format(objFile.DateLastModified, "DD.MM.YY")
                    strObemRedakt = objFile.Size
                    'заносим в таблицу
                    Call PrintFile
                End If
        Next i
    End If
Else
        MsgBox "Не найдено подходящих файлов"
End If
        Exit Sub
        MsgBox "Формирование описи завершено!" & vbCrLf & "Внесено - " & rP -  1  & " файлов.", vbInformation + vbOKOnly, "Поздравляю ;)"
End With
End Sub