MyTetra Share
Делитесь знаниями!
Просмотреть все файлы в папке
16.03.2019
23:43
Текстовые метки: FileDialog,fso,Open,Workbooks.Open
Раздел: !Закладки - VBA - GetOpen

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

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

Sub Get_All_File_from_Folder() Dim sFolder As String, sFiles 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 sFiles = Dir(sFolder & "*.xls*") Do While sFiles <> "" 'открываем книгу Workbooks.Open sFolder & sFiles 'действия с файлом 'Запишем на первый лист книги в ячейку А1 - www.excel-vba.ru ActiveWorkbook.Sheets(1).Range("A1").Value = "www.excel-vba.ru" 'Закрываем книгу с сохранением изменений ActiveWorkbook.Close True 'если поставить False - книга будет закрыта без сохранения sFiles = Dir Loop 'возвращаем ранее отключенное обновление экрана Application.ScreenUpdating = True End Sub


1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

Sub Get_All_File_from_Folder()

    Dim sFolder As String, sFiles 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

    sFiles = Dir(sFolder & "*.xls*")

    Do While sFiles <> ""

        'открываем книгу

        Workbooks.Open sFolder & sFiles

        'действия с файлом

        'Запишем на первый лист книги в ячейку А1 - www.excel-vba.ru

        ActiveWorkbook.Sheets(1).Range("A1").Value = "www.excel-vba.ru"

        'Закрываем книгу с сохранением изменений

        ActiveWorkbook.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 в указанной папке, включая все подпапки:

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 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 'действия с файлом 'Запишем на первый лист книги в ячейку А1 - www.excel-vba.ru ActiveWorkbook.Sheets(1).Range("A1").Value = "www.excel-vba.ru" ActiveWorkbook.Close True End If Next For Each objFolder In objFolder.SubFolders GetSubFolders objFolder.Path & Application.PathSeparator Next End Sub


1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

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

    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

            'действия с файлом

            'Запишем на первый лист книги в ячейку А1 - www.excel-vba.ru

            ActiveWorkbook.Sheets(1).Range("A1").Value = "www.excel-vba.ru"

            ActiveWorkbook.Close True

        End If

    Next

    For Each objFolder In objFolder.SubFolders

        GetSubFolders objFolder.Path & Application.PathSeparator

    Next

End Sub

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


1

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

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

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

  Tips_Macro_Get_All_Files_from_Folder.xls (56,5 KiB, 4 114 скачиваний)


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

В последнее время участились вопросы как просмотреть еще и все диски. Поэтому решил выложить код, который просматривает все подключенные диски и выводит список всех файлов в них. Для работы кода достаточно разместить его в одном модуле с кодом выше:

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


1

2

3

4

5

6

7

8

9

10

11

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

Прикрепленные файлы:
Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования