Макрос для всех книг excel в папке

Skip to content

Sub OtkritVseKnigi()
'Шаг 1:Объявляем переменные
Dim MyFiles As String
'Шаг 2: Укажите нужную папку
MyFiles = Dir("C:Temp*.xlsx")
Do While MyFiles <> “”
'Шаг 3: Открываем файлы один за другим
Workbooks.Open "C:Temp" & MyFiles
'Код макроса с действиями
MsgBox ActiveWorkbook.Name
ActiveWorkbook.Close SaveChanges:=True
'Шаг 4: Следующий файл в папке
MyFiles = Dir
Loop
End Sub

Сам отвечу на свой вопрос ))  

  Sub Open_Workbooks()  
Application.ScreenUpdating = False  
Application.Calculation = xlManual ‘xlCalculationManual  

   Const iPath$ = «C:Vedomosti2012tekushie» ‘Здесь необходимо указать нужную папку  

   If Dir(iPath$, vbDirectory) = «» Then  
  ‘проверку можно не использовать, если Вы уверены в наличии папки  
  ‘или если она выбрана с использованием диалогового окна  
  MsgBox «Странно, но указанная папка изволит отсутствовать», _  
  vbExclamation + vbSystemModal, «Ошибка пользователя !!!»  
  Exit Sub  
End If  

   iFileName$ = Dir(iPath$ & «*.xls»)  
Do While iFileName$ <> «»  
  If iFileName$ <> ThisWorkbook.Name Then  
     ‘проверку можно не использовать, если рабочая книга, в которой  
     ‘находится исполняемый код находится совсем в другой папке  
    With Workbooks.Open(Filename:=iPath$ & iFileName$)  
          ‘если эта книга всё же находится в указанной папке,  
          ‘то достаточно Workbooks.Open(FileName:=iFileName$)  
          ‘  
          ‘Здесь манипуляции с Вашей рабочей книгой  
          ‘.Close saveChanges:=True  
     End With  
   End If  
 iFileName$ = Dir  
Loop  
Application.ScreenUpdating = True  
Application.Calculation = xlAutomatic ‘xlCalculationAutomatic  
End Sub

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

Для работы этого макроса, помимо него самого, вам понадобится добавить в свой файл:

1. функцию FilenamesCollection для получения списка файлов в папке
2. функцию GetFolder для вывода диалогового окна выбора папки с запоминанием выбранной папки
3. прогресс-бар для отображения процесса обработки файлов (модуль класса и форму)

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

После того, как очередной файл обработан, он перемещается во вторую папку («архив»).

Код макроса:

Sub ИмпортДанныхИзЗаявок()
    On Error Resume Next: Err.Clear
    ' запрашиваем пути к папкам с файлами
    InvoiceFolder$ = GetFolder(1, , "Выберите папку с файлами заявок (из Outlook)")
    If InvoiceFolder$ = "" Then MsgBox "Не задана папка с заявками", vbCritical, "Обработка заявок невозможна": Exit Sub
 
    ArchieveFolder$ = GetFolder(2, , "Выберите папку, куда будут помещаться обработанные файлы заявок")
    If ArchieveFolder$ = "" Then MsgBox "Не задана папка для архива заявок", vbCritical, "Обработка заявок невозможна": Exit Sub
 
    Dim coll As Collection
    ' загружаем список файлов по маске имени файла
    Set coll = FilenamesCollection(InvoiceFolder$, "Заявка №*от*.xls*", 1)
 
    If coll.Count = 0 Then
        MsgBox "Не найдено ни одной заявки для обработки в папке" & vbNewLine & InvoiceFolder$, _
               vbExclamation, "Нет необработанных заявок"
        Exit Sub
    End If
 
    Dim pi As New ProgressIndicator: pi.Show "Обработка заявок", , 2
    pi.StartNewAction , , , , , coll.Count    ' отображаем прогресс-бар

    Dim WB As Workbook, sh As Worksheet, ra As Range
    Application.ScreenUpdating = False  ' отключаем обновление экрана (чтобы процесс открытия файлов не был виден)

    ' перебираем все найденные в папке файлы
    For Each Filename In coll
 
        ' обновляем информацию на прогресс-баре
        pi.SubAction "Обрабатывается заявка $index из $count", "Файл заявки: " & Dir(Filename), "$time"
        pi.Log "Файл: " & Dir(Filename)
 
        ' открываем очередной файл в режиме «только чтение»
        Set WB = Nothing: Set WB = Workbooks.Open(Filename, False, True)
 
        If WB Is Nothing Then    ' не удалось открыть файл
            pi.Log vbTab & "ОШИБКА при загрузке файла. Файл не обработан."
 
        Else    ' файл успешно открыт
            Set sh = WB.Worksheets(1)    ' будем брать данные с первого листа
            ' берем диапазон ячеек с ячейки B1 до последней заполненной в столбце B
            Set ra = sh.Range(sh.Range("b1"), sh.Range("b" & sh.Rows.Count).End(xlUp))
 
            ' ==== переносим данные в наш файл (shb - кодовое имя листа, куда помещаем данные)
            shb.Range("a" & shb.Rows.Count).End(xlUp).Offset(1).Resize(, ra.Rows.Count).Value = _
            Application.WorksheetFunction.Transpose(ra.Value)
            ' ==== конец обработки данных из очередного файла

            WB.Close False: DoEvents    ' закрываем обработанный файл без сохранения изменений
            pi.Log vbTab & "Файл успешно обработан."
 
            ' перемещаем обработанный файл из папки InvoiceFolder$ в папку ArchieveFolder$
            Name Filename As ArchieveFolder$ & Dir(Filename, vbNormal)
 
        End If
    Next
 
    ' закрываем прогресс-бар, включаем обновление экрана
    pi.Hide: DoEvents: Application.ScreenUpdating = True
    MsgBox "Обработка заявок завершена", vbInformation
End Sub

Во вложении — файл со всеми необходимыми макросами для сбора данных из других файлов Excel

Хитрости »

20 Июль 2012              137538 просмотров

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

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

В примере я закомментировал строки, открывающие файл и вносящие изменения в ячейку

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 (61,5 KiB, 8 204 скачиваний)

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

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

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

    Видеоуроки

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



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

Представьте, вы написали классный макрос, который автоматизирует работу одного Excel-файла. Теперь проблема заключается в том, что вам нужно перейти в папку, открыть каждую книгу, запустить макрос, сохранить изменения, закрыть книгу, а затем открыть следующую. Открытие каждой рабочей книги в папке, как правило, ручной процесс, который отнимает много времени. Этот макрос решает проблему, как открыть все рабочие книги папки. 

В этом макросе, мы используем функцию Dir. Функция Dir возвращает строку, которая представляет собой имя файла. С её помощью в указанной папке мы возьмём имя каждого файла (с расширением “.xlsx”), затем будем открывать каждый файл, запускать макрос и, наконец, закрывать файл после сохранения.