Использование информации атрибута файла для таблицы Excel

[choky]

Доброго всем дня, помогите, пожалуйста реализовать следующий макрос:
Необходимо чтобы макрос пробежался по папке, нашёл в ней все эксель файлы и записал даты создания этих файлов в таблицу рабочего листа, если дата создания изменилась подкрасить это, если дата создания сегодняшняя, то подкрасить в другой цвет.
Собственно вопрос - как макросом реализовать считывание значения даты создания файла?
Заранее благодарю.

[EducatedFool]

Задал Гуглу вопрос: "excel получить дату создания файла"

В первом же результате поиска - 3 варианта макроса: http://forum.sysman.ru/index.php?showtopic=20151


Пример нужного Вам макроса есть в этой теме: http://www.programmersforum.ru/showthread.php?t=30219
Надо лишь добавить условие, чтобы в таблицу попадали только файлы с расширением XLS

[choky]

большое спасибо...видно плохо искал, прошу прощения

[choky]

еще раз здравствуйте.
а не подскажете как все-таки реализовать фильтрацию файлов по расширению (возможно ли это сделать на стадии получения информации об атрибутах файлов с помощью FSO, или это можно сделать только с готовым результатом, который уже попал в таблицу).
на примере вашего кода:

Sub CreateDirectoryListing()
    On Error Resume Next
    'Dim fso As FileSystemObject, f As Folder, fl As File, fld As Folder

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder("c:\mydocs")

    Application.ScreenUpdating = False
    Dim sh As Worksheet: Set sh = ActiveWorkbook.Worksheets.Add
    ro = 2
    With sh
        .Cells(1, 1).Resize(1, 4).Interior.Color = vbGreen:
        .Cells(1, 1) = "название папки": .Cells(1, 2) = "тип":
        .Cells(1, 3) = "дата создания": .Cells(1, 4) = "размер папки":
        For Each fld In f.Subfolders
            .Cells(ro, 1) = fld.Name
            .Cells(ro, 2) = fld.Type
            .Cells(ro, 3) = fld.DateCreated
            .Cells(ro, 4) = FileOrFolderSize(fld.Size)
            ro = ro + 1: DoEvents
        Next
        ro = ro + 1
        .Cells(ro, 1) = "Название файла": .Cells(ro, 2) = "Тип файла":
        .Cells(ro, 3) = "Дата создания": .Cells(ro, 4) = "Размер файла"
        .Cells(ro, 1).Resize(1, 4).Interior.Color = vbMagenta: ro = ro + 1
        For Each fl In f.Files
            .Cells(ro, 1) = fl.Name
            .Cells(ro, 2) = fl.Type
            .Cells(ro, 3) = fl.DateCreated
            .Cells(ro, 4) = FileOrFolderSize(fl.Size)
            ro = ro + 1: DoEvents
        Next
        .Columns("a:e").AutoFit
        .UsedRange.HorizontalAlignment = xlCenter
        SetRangeBordersEx .UsedRange, xlContinuous, xlThin
    End With
    Application.ScreenUpdating = True
End Sub

[EducatedFool]

Попробуйте такой вариант:

Sub CreateDirectoryListing()
    On Error Resume Next

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder("D:\Документы")

    Application.ScreenUpdating = False
    Dim sh As Worksheet: Set sh = ActiveWorkbook.Worksheets.Add
    ro = 1
    With sh
        .Cells(ro, 1) = "Название файла": .Cells(ro, 2) = "Тип файла":
        .Cells(ro, 3) = "Дата создания": .Cells(ro, 4) = "Размер файла"
        .Cells(ro, 1).Resize(1, 4).Interior.Color = vbMagenta: ro = ro + 1

        For Each fl In f.Files
            If fl.Name Like "*.xls" Then
                .Cells(ro, 1) = fl.Name
                .Cells(ro, 2) = fl.Type
                .Cells(ro, 3) = fl.DateCreated
                .Cells(ro, 4) = FileOrFolderSize(fl.Size)
                ro = ro + 1: DoEvents
            End If
        Next
        .Columns("a:e").AutoFit
        .UsedRange.HorizontalAlignment = xlCenter
        SetRangeBordersEx .UsedRange, xlContinuous, xlThin
    End With
    Application.ScreenUpdating = True
End Sub


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

Sub SetRangeBordersEx(ByRef ra As Range, ByVal BordersLineStyle As XlLineStyle, ByVal BordersWeight As XlBorderWeight)
    ra.Borders.LineStyle = BordersLineStyle
    ra.Borders.Weight = BordersWeight
    ra.Borders(xlDiagonalDown).LineStyle = xlNone
    ra.Borders(xlDiagonalUp).LineStyle = xlNone
End Sub

[choky]

Всё здорово и изящно работает - спасибо большое