Dim sName As String, oFSO As Object, oItem As Object, li As Long
Set oFSO = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then Exit Sub
sName = .SelectedItems(1)
End With
Range("A1:B1").Value = Array("Папка", "Дата создания")
For Each oItem In oFSO.GetFolder(sName).SubFolders
li = li + 1
Cells(li, 1).Value = oItem.Name
ActiveSheet.Hyperlinks.Add Anchor:=Cells(li, 1), Address:=sName & "\" & oItem.Name, TextToDisplay:=oItem.Name
Cells(li, 2).Value = oItem.DateCreated
Next oItem

Sub d()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            With Application: .ScreenUpdating = 0: .EnableEvents = 0: .DisplayAlerts = 0: End With
            CreateObject("wscript.shell").Run _
                "cmd /c dir " & .SelectedItems(1) & _
                " /AD-H-L-S | clip", 0, 1
            With ActiveSheet
                .[A1:B1] = Array("Папка", "Дата создания")
                With Intersect(.UsedRange.Offset(1), .[A:B])
                    .Cells(1, 1).Select
                    .Delete xlUp
                End With
                .PasteSpecial "Текст"
                .UsedRange
                With Intersect(.UsedRange.Offset(1), .[A:A])
                    .Columns(1).TextToColumns [A2], 2, FieldInfo:=Array( _
                    Array(0, 4), Array(10, 9), Array(36, 2)), TrailingMinusNumbers:=1
                    .Offset(, 1).Cut
                    .Insert xlToRight
                    .Offset(.Rows.Count - 3, -1).Resize(2, 2).Delete xlUp
                    .Offset(, -1).Resize(5, 2).Delete xlUp
                End With
            End With
        End If
    End With
    With Application: .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1: End With
End Sub