Иногда необходимо проделать однотипные операции с несколькими файлами, расположенными в одной папке. Можно открывать каждый по очереди:
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 КиБ, 8 921 скачиваний)


В примере я закомментировал строки, открывающие файл и вносящие изменения в ячейку 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 КиБ, 8 921 скачиваний)


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

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

Loading

55 комментариев

  1. День добрый.
    Традиционно спасибо за этот макрос!
    А помогите, пожалуйста, как корректнее доработать код, чтобы можно было совместить - в список файлов вносить не просто все найденные в папках и подпапках, а только те, в которых находится определенное наименование листа (например, Лист1), при этом сам такой лист переименовывать в нужный (например, Лист2), после чего в список на отдельный лист исходного файла (откуда запускаем макрос) вносить только те файлы, в которых был переименован лист. Если такого листа (Лист1) не находится - просто переходим к следующему файлу, пока есть что перебирать.
    Я отсматриваю файлы, созданные не ранее 10 дней

    Никак не справлюсь - если пишу так, то исходный файл закрывается без сохранения ((
    -----------------------------------------------------------------------
    For Each objFile In objFolder.Files
    If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls*" And FileDateTime(objFile) >= Now() - 10 Then

    ' '================================
    ' 'Открытие книг:
    ' 'открываем книгу
    Workbooks.Open sPath & objFile.Name
    ' 'действия с файлом
    ' 'проверяем название листа на совпадение с Лист1
    If ActiveWorkbook.Sheets(1).Name = "Лист1" Then ActiveWorkbook.Sheets(1).Name = "Лист2"

    ActiveWorkbook.Close True

    Else: ActiveWorkbook.Close False

    'заносим полное имя файла в список файлов
    ReDim Preserve vFolders(lCount)
    vFolders(lCount) = sPath & objFile.Name
    lCount = lCount + 1

    End If
    Next

    1. Я бы для начала проверял - а нет ли в книге листа с именем "Лист2". Иначе вполне возможно появление ошибки и лист не будет переименован. А если где-то выше по коду еще есть и пропуск ошибок(On Error Resume Next) - то Вы об этом даже и не узнаете, код просто пойдет дальше без всяких сообщений. Пока других идей описанного поведения кода нет.
      Проще всего будет проверять имя листа в книге отдельной функцией. Здесь есть готовый код: Как узнать существует ли лист в книге?

Добавить комментарий для Александр Отменить ответ

Этот сайт использует Akismet для борьбы со спамом. Узнайте, как обрабатываются ваши данные комментариев.