Lost your password?


Хитрости »
Основные понятия (27)
Сводные таблицы и анализ данных (10)
Графики и диаграммы (5)
Работа с VB проектом (12)
Power BI и Power Query (23)
Условное форматирование (5)
Списки и диапазоны (5)
Макросы(VBA процедуры) (68)
Разное (43)
Баги и глюки Excel (5)

Просмотреть все файлы в папке

Иногда необходимо проделать однотипные операции с несколькими файлами, расположенными в одной папке. Можно открывать каждый по очереди:
Workbooks.Open "C:\Новая папка\Книга1.xlsx"
Workbooks.Open "C:\Новая папка\Книга2.xlsx"

и т.д.
Но если файлов много и все с разными именами, то это не очень практично и совсем лишено гибкости. При помощи Visual Basic for Application можно решить проблему. При этом файлы можно просматривать как в одной папке, так и включая вложенные "подпапки".


 

Все файлы в папке
Ниже приведен код, который перебирает все файлы в папке, открывает их и на первом листе каждого файла записывает текст "www.excel-vba.ru" в ячейку A1:

Sub Get_All_File_from_Folder()
    Dim sFolder As String, sFiles As String
    Dim wb As Workbook
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
        'открываем книгу
        Set wb = Application.Workbooks.Open(sFolder & sFiles)
        'действия с файлом
        'Запишем на первый лист книги в ячейку А1 - www.excel-vba.ru
        wb.Sheets(1).Range("A1").Value = "www.excel-vba.ru"
        'Закрываем книгу с сохранением изменений
        wb.Close True 'если поставить False - книга будет закрыта без сохранения
        sFiles = Dir
    Loop
    'возвращаем ранее отключенное обновление экрана
    Application.ScreenUpdating = True
End Sub

sFiles = Dir(sFolder & "*.xls*") - Строка отвечает за тип перебираемых файлов. В примере будут просмотрены любые файлы Excel. Звездочка на конце означает любой символ или набор символов. Т.е. если указать без неё - "*.xls", то будут просмотрены только файлы с расширением xls, а если указать xlsx - то файлы с расширением xlsx и никакие другие.
Если хотите перебрать файлы других форматов, а не Excel, то просто замените "*.xls" на нужное расширение. Например "*.doc". Также, если хотите собрать только файлы с определенными символами/словами в имени, то можно указать так: sFiles = Dir(sFolder & "*отчет*.xls*"). Будут просмотрены все файлы, содержащие в имени слово "отчет"(например "отчет за июнь.xls", "отчет за июль.xls", "сводный отчет.xls" и т.п.).


 

Все файлы включая подпапки
В коде выше есть одна проблема: что если необходимо открыть файлы не только в указанной папке, но и во всех её подпапках? В версиях Excel 2003 и младше это решалось с помощью метода .FileSearch, но в старших версиях данный метод по каким-то причинам был заблокирован разработчиками Microsoft. И осталось действовать только через рекурсивный метод перебора папок. Ниже приведен код, который открывает все файлы Excel в указанной папке, включая все подпапки.
Для этого используется встроенная в офис библиотека File System Object:

Option Explicit
 
Dim objFSO As Object, objFolder As Object, objFile As Object
 
Sub Get_All_File_from_SubFolders()
    Dim sFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    GetSubFolders sFolder
    Set objFolder = Nothing
    Set objFSO = Nothing
    Application.ScreenUpdating = True
End Sub
Private Sub GetSubFolders(sPath)
    Dim sPathSeparator As String, sObjName As String
    Dim wb As Workbook
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then
            'открываем книгу
            Set wb = Application.Workbooks.Open(sPath & objFile.Name)
            'действия с файлом
            'Запишем на первый лист книги в ячейку А1 - www.excel-vba.ru
            wb.Sheets(1).Range("A1").Value = "www.excel-vba.ru"
            wb.Close True 'wb.Close False '- если в коде надо будет закрывать книгу без сохранения
        End If
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders objFolder.Path & Application.PathSeparator
    Next
End Sub

Код делает тоже самое, что и первый, но открывает и изменяет ячейку A1 первого листа для всех файлов Excel в выбранной папке и всех её подпапках(включая все вложенные до последнего уровня).

If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then

Строка отвечает за тип перебираемых файлов. В примере будут просмотрены любые файлы Excel. Звездочка на конце означает любой символ или набор символов. Т.е. если указать без неё - "*.xls", то будут просмотрены только файлы с расширением xls, а если указать xlsx - то файлы с расширением xlsx и никакие другие.
Если добавить условие: If objFSO.GetBaseName(objFile) Like "*книга*" Then
то будут обработаны файлы, которые в имени содержат слово "книга". При этом регистр букв имеет значение. Т.е. если файл содержит в имени слово "Книга", то он не будет обработан.
Думаю теперь Вы легко сможете проделать необходимые операции с множеством файлов.

Скачать пример:

  Все файлы в папке и подпапках.xls (62,5 KiB, 8 637 скачиваний)


В примере я закомментировал строки, открывающие файл и вносящие изменения в ячейку A1 и заменил это созданием списка имен всех файлов в папках и подпапках. По окончании работы кода имена всех файлов записываются в столбец "А" нового листа(лист создается автоматически). Сделано для того, чтобы при тестировании кода случайно не повредить информацию в файлах.


 

Просмотреть все файлы на всех дисках
В последнее время участились вопросы как просмотреть еще и все диски на ПК. Ниже выкладываю код, который просматривает все подключенные диски и просматривает все файлы во всех папках дисков:

Sub Get_All_drives()
    Dim objDrives As Object, objDrive As Object
 
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objDrives = objFSO.Drives
    For Each objDrive In objDrives
        If objDrive.IsReady Then
            GetSubFolders objDrive.DriveLetter & ":\"
        End If
    Next objDrive
End Sub

Для работы кода необходимо разместить его в том же модуле, что и код просмотра файлов в подпапках. Без него код просмотра дисков работать не будет, т.к. обращается к процедуре GetSubFolders(которая и приведена в коде перебора файлов в подпапках).
Скачать пример:

  Все файлы в папке и подпапках.xls (62,5 KiB, 8 637 скачиваний)


В примере код сканирует все диски и выводит в столбец А нового листа(лист создается автоматически) пути ко всем файлам.

Так же см.:
Как средствами VBA переименовать/переместить/скопировать файл
Как сменить формат сразу для нескольких файлов Excel
Как удалить папку или все файлы из папки через VBA
Собрать и просуммировать данные из разных файлов при помощи PowerQuery


Статья помогла? Поделись ссылкой с друзьями!
  Плейлист   Видеоуроки

Поиск по меткам

Access apple watch Multex Power Query и Power BI VBA управление кодами Бесплатные надстройки Дата и время Записки ИП Надстройки Печать Политика Конфиденциальности Почта Программы Работа с приложениями Разработка приложений Росстат Тренинги и вебинары Финансовые Форматирование Функции Excel акции MulTEx ссылки статистика
Обсуждение: 55 комментариев
  1. Sophie:

    Здесь кроется очень нужная мне информация, поэтому постараюсь разобраться.

    Где у вас в программе указан путь к файлам? (буду говорить о первом код-е)

  2. Sophie, а запустить код не пробовали? Он кроется в диалоге выбора папки с файлами. И переменная, в которой путь хранится называется тоже без подвоха - sFolder.

  3. Елена:

    Попробовала использовать Ваш код, получилось так (код ниже). Он работает, но просматривает не все папки. У меня 35 папок, в которых в сумме около 300 файлов. Мне нужно каждый открыть, скопировать диапазон, вставить в рабочий файл и закрыть. Названия в файлах очень длинные, но уменьшить их не могу - так экспортирует программа и в имени содержится нужная для обработки информация. Может код не работает из-за длинных имён и можно это как-то исправить? или, возможно у меня какая-то недописка в коде получилась? Макросы изучаю "методом тыка"
    Тот код, что в примере есть - выводит все имена файлов и папок, которые у меня есть. А тот, что я попыталась переделать под свою программу - нет.

    Option Explicit
     
    Dim vFolders(), lCount As Long
    Dim objFSO As Object, objFolder As Object, objFile As Object
     
     
    Sub Get_All_File_from_SubFolders()
     
        Dim sFolder As String
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = False Then Exit Sub
            sFolder = .SelectedItems(1)
        End With
        sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
     
        Application.ScreenUpdating = False
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        GetSubFolders sFolder
        Set objFolder = Nothing
        Set objFSO = Nothing
        Application.ScreenUpdating = True
    End Sub
     
    Private Sub GetSubFolders(sPath)
     
     
     
    Dim y As Integer
    Dim i, j, b, c, d, e As Integer
    Dim a As Long
    Dim x, x1 As String
    Dim sPathSeparator As String, sObjName As String
        Set objFolder = objFSO.GetFolder(sPath)
        For Each objFile In objFolder.Files
            If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls" Then
                'открываем книгу
                Workbooks.Open sPath & objFile.Name
     
     
     
    x = ActiveWorkbook.Name
    x1 = Left(x, Len(x) - 4)
     
    'копирование информации в цикле
    'лист Загальні відомості
    e = 3
    Do
        If ActiveWorkbook.ActiveSheet.Cells(e, 1)  "" Then
            e = e + 1
        End If
    Loop Until ActiveWorkbook.ActiveSheet.Cells(e, 1) = ""
    Range(Cells(3, 1), Cells(e - 1, 13)).Select
    Selection.Copy
     
    Windows("Luganska_obl_rezultati_ZNO.xls").Activate
    Sheets("Відомості по територіям").Select
    a = 4
    Do
        If x Like "*" & Cells(a, 3).Text & "*" Then
            If x Like "*" & Cells(a, 4) & "*" Then
                c = 7
                If Cells(a + c, 5).Value = "" Then
                    Range(Cells(a + c, 5), Cells(a + c + e - 4, 17)).Select
                    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, operation:=xlNone, skipblanks:=False, Transpose:=False
                    Exit Do
                Else
                   a = a + 1
                   If Cells(a + c - 1, 5).Text = Workbooks(x).Sheets(x1).Cells(3, 1) Then
                        MsgBox "Такі школи вже є!"
                        Exit Do
                   End If
                End If
                Else
                    a = a + 109
            End If
            Else
            a = a + 1526
                End If
    Loop Until ActiveWorkbook.ActiveSheet.Cells(a, 3).Text = ""
    'close book
     
    Application.CutCopyMode = False
    Workbooks(x).Close True
     
     
            End If
        Next
        For Each objFolder In objFolder.SubFolders
            GetSubFolders objFolder.Path & Application.PathSeparator
        Next
     
    End
    End Sub
  4. Елена, уберите End из последней процедуры. End - это завершение ВСЕХ выполняемых процедур. Окуда Вы его взяли и зачем поместили - известно только Вам.

  5. Елена:

    Спасибо, как раз зашла написать, что нашла ошибку - End в конце. Я где-то вычитала, что его нужно ставить для того, чтобы очистить память после выполнения макроса. Но сейчас прогнала 300 файлов и нормально - компьютер не завис.

  6. Наталия:

    Подскажите, пожалуйста. В первом макросе почему то не видит файлы Excel.

  7. Наталия, что подсказать? Если бы это было действительно так, то я бы не выкладывал код. У всех работает и все видит. Проблема либо в самих файлах(они имеют иное расширение), либо Вы что-то не так сделали.

  8. Клара:

    подскажите пожалуйста, вот он перебирает файлы: один файл, затем второй и т.д. и как сделать так чтобы в этом цикле он сравнивал столбцы в тех файлах, в которых в названии присутствует слово, например "Москва"?

  9. Клара, это вопрос скорее для форума уже. Т.к.
    1. Вопрос не имеет отношения к статье(т.к. действия с файлом могут быть разные).
    2. Совершенно неясно с чем надо сравнивать столбцы "Москва". Да и реализация не уложится в одну строку. И без файла примера тоже не обойтись.

    • Клара:

      спасибо большое за ответ)буду на форумы обращаться)

        • Клара:

          а вот возник другой вопрос...когда мы выбираем папку, в которой хранятся наши .xls файл (выбрала самый ваш первый вариант), как сделать так чтобы в других модулях не запрашивалась опять папка

          • Не совсем понятно, про какие модули речь и почему они тоже должны запрашивать папку...Если речь про подобные процедуры - то можно определить основную, которая запрашивает папку. После выбора записывает путь к папке в определенную ячейку книги. А остальные процедуры берут путь уже из этой ячейки.

  10. Клара:

    ну все макросы у меня хранятся в Personal. в module1 у меня основной код, в нём идет выбор папки, где хранятся excel файлы, далее в этом модуле вызываются другие макросы,которые находятся в module2, где в начале такой же код для выбора папки. как сделать так чтобы в module2 он не спрашивал опять папку)

Поделитесь своим мнением

Комментарии, не имеющие отношения к комментируемой статье, могут быть удалены без уведомления и объяснения причин. Если есть вопрос по личной проблеме - добро пожаловать на Форум


Для оформления сообщений Вы можете использовать следующие тэги:
<a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <s> <strike> <strong>

Тренинги

Заказать
Юридическая информация

Использование материалов сайта

Политика Конфиденциальности

ИП Щербаков Дмитрий Валентинович
ОГРНИП: 318502700083307
ИНН: 504013350772

Наши партнеры

Перейти

Счетчики

Рейтинг@Mail.ru Яндекс.Метрика
© 2024 Excel для всех   Войти