Ярлыки

(16) 1С 8.3 (1) 2GIS (1) автоактивация (3) Активация (3) Андроид (113) Антивирус (2) Аудио (2) биоритмы (1) Блок питания (22) боль в спине (1) браузер (2) бросить курить (1) буквы соответствие (1) бумажник (1) бюджетирование (1) ВАЗ 2110 (1) вацап (1) видеонаблюдение (8) Видеосвязь (1) гаджет (1) Галстук (1) геокоординаты (1) дача (1) для дома (1) дом (2) драйвера (6) Дубликаты (1) еда (1) запись (1) Зарядка акб (1) Зарядное устройство (1) звук (4) здоровье (8) знаки зодиака (1) зрение (1) игнтернет (1) иероглифы (1) Изделия из дерева (1) Интернет (10) Интернет-магазины (3) Кино (1) ключница (1) Книги Журналы (1) кожаная обувь (4) командная строка (1) конвертор (1) кошелек (1) кресло-качалка (1) кухня (2) Лекарства (1) логика (1) макрос (1) медицина (1) мозги (1) морщины (2) мтс (1) музыка (9) мультики (1) Мыльные_пузыри (1) Натуральная кожа (56) Облако (1) омск (1) Он Лаин библиотеки (1) органайзер (1) оригами (1) Отбеливание (1) отслеживание посылок (1) Папка (1) Пароли (2) пароль (3) партмоне (1) парфюм (1) переименование файлов (1) питание (1) Планшет (5) поза сна (1) поздравление (1) поиск (1) поиск дублей (1) поисковик (1) Полезные сайты (1) портабле (2) принтер (4) Программы (58) простуда (1) расширения (1) редактор музыкальных файлов (1) Русский язык (1) рут (2) сеть (8) Скрыть информацию (1) Стиль (1) стихи (2) сумка (1) суставы (3) теги (1) трек-номер (1) тренинг (1) тренинг памяти (1) удаленный доступ (2) узлы (1) УНЧ (3) Управление компьютером (2) Управленческий учет (2) Успокоительные средства (1) фильмы (2) Флешка (53) фото (2) цвета в одежде (1) цена (1) экран не гаснет (1) эл почта (2) Ютуб (1) Access (10) Acronis True Image WD Edition (1) AliExpress (1) ALT-коды (1) audi (1) Avira Antivirus (1) bat (2) BIOS (4) chrom (15) Chrome (2) Cube iPlay 10 U83 (1) Dism++ (2) epson 1260 (1) ERD Commander (1) Excel (42) Faceter (1) Firefox (1) GHOST32 (4) gif анимация (1) Google (1) Google Hrome (1) Google Play (1) Grub4Dos (7) HDD (1) Honor (1) HP USB Disk Storage Tool (1) IPTV (1) KPI (1) Linux (16) NirCmd (1) office (4) PDF (1) Pinterest (1) portable (2) Prestigio3502 (1) Rufus (2) SSD (1) torrent (1) UEFI (1) VBA (42) WEB ресурсы (2) WiFi (2) Windows (77) Windows 10 (5) Windows 11 (2) Windows 7 (24) YouTube (15)

четверг, 16 апреля 2015 г.

Макрос VBA Excel выводит содержание папки




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 = "=HYPERLINK(""" & FileItem.Path & """)"
        '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

Комментариев нет:

Отправить комментарий