Каталог расширений

Популярные теги

3gp       avi       fb2       jpg       mp3       pdf      

Главная » Разное » Как применить макрос ко всем файлам в папке

Как применить макрос ко всем файлам в папке


Как применить макрос VBA ко всем файлам в каталоге?

У меня есть подкаталог с ~ 1000 документами Word, я бы хотел применить следующий макрос для создания гиперссылок для каждого из них, но я не могу открыть их для запуска скрипта. Есть ли способ, чтобы я мог применить его к каждому документу в каталоге? Могу ли я назвать это из сценария bash?

Sub FormatLinks()
 Dim H As Hyperlink
 
 For Each H In ActiveDocument.Hyperlinks
 H.Range.Select ' (A)
 Selection.ClearFormatting ' (B)
 
 H.Range.Style = ActiveDocument.Styles("Hyperlink") ' (C)
 Next H
 End Sub

Это из фильтра, программа, которая фильтрует stdin в stdout. Эта часть здесь — запустить скрипт командной строки, указанный в каждой строке файла. Dir/b дает вам список файлов.

Set Arg = WScript.Arguments
 set WshShell = createObject("Wscript.Shell")
 Set Inp = WScript.Stdin
 Set Outp = Wscript.Stdout
 RawScript = Arg(1)
 'Remove ^ from quoting command line and replace : with vbcrlf so get line number if error
 Script = Replace(RawScript, "^", "")
 Script = Replace(Script, "'", chr(34))
 Script = Replace(Script, ":", vbcrlf)
 'Building the script with predefined statements and the user code
 Script = "Dim gU" & vbcrlf & "Dim gdU" & vbcrlf & "Set gdU = CreateObject(" & chr(34) & "Scripting.Dictionary" & chr(34) & ")" & vbcrlf & "Function UF(L, LC)" & vbcrlf & "Set greU = New RegExp" & vbcrlf & "On Error Resume Next" & vbcrlf & Script & vbcrlf & "End Function" & vbcrlf
 
 'Testing the script for syntax errors
 On Error Resume Next
 set ScriptControl1 = wscript.createObject("MSScriptControl.ScriptControl",SC)
 With ScriptControl1
 .Language = "VBScript"
 .UseSafeSubset = False
 .AllowUI = True
 .AddCode Script
 End With
 With ScriptControl1.Error
 If .number <> 0 then
 Outp.WriteBlankLines(1)
 Outp.WriteLine "User function syntax error"
 Outp.WriteLine "=========================="
 Outp.WriteBlankLines(1)
 Outp.Write NumberScript(Script)
 Outp.WriteBlankLines(2)
 Outp.WriteLine "Error " & .number & " " & .description
 Outp.WriteLine "Line " & .line & " " & "Col " & .column
 Exit Sub
 End If
 End With
 
 ExecuteGlobal(Script)
 
 'Remove the first line as the parameters are the first line
 'Line=Inp.readline 
 Do Until Inp.AtEndOfStream
 Line=Inp.readline
 LineCount = Inp.Line 
 
 temp = UF(Line, LineCount)
 If err.number <> 0 then 
 outp.writeline ""
 outp.writeline ""
 outp.writeline "User function runtime error"
 outp.writeline "==========================="
 Outp.WriteBlankLines(1)
 Outp.Write NumberScript(Script)
 Outp.WriteBlankLines(2)
 Outp.WriteLine "Error " & err.number & " " & err.description
 Outp.WriteLine "Source " & err.source
 
 Outp.WriteLine "Line number and column not available for runtime errors"
 wscript.quit
 End If
 outp.writeline temp
 Loop

Общее использование

filter <inputfile >outputfile
 filter <inputfile | other_command
 other_command | filter >outputfile
 other_command | filter | other_command
 
 Vbs
 
 filter vbs "text of a vbs script"
 filter vb "text of a vbs script"

Используйте двоеточия для разделения операторов и строк. Используйте одиночные кавычки вместо двойных кавычек, если вам нужна одна цитата, использующая chr (39). Скопируйте скобки и амперсанд с символом ^. Если вам понадобится использование каретки chr (136).

Функция называется UF (для UserFunction). Он имеет два параметра: L, который содержит текущую строку и LC, который содержит linecount. Задайте результаты сценария UF. См. Пример.

Доступны три глобальных объекта. Необъявленная глобальная переменная gU для поддержания состояния. Используйте его как массив, если вам нужно больше одной переменной. Объект словаря gdU для сохранения и доступа к предыдущим строкам. И объект RegExp greU готов к использованию.

пример

Этот скрипт vbs вставляет номер строки и устанавливает строку в функцию UF, которая отфильтровывает фильтр.

filter vbs "uf=LC ^& ' ' ^& L"<"%systemroot%\win.ini"

Вот как он выглядит в памяти

Dim gU
 Set gdU = CreateObject("Scripting.Dictionary")
 Set greU = New RegExp
 
 Function UF(L, LC)
 
 ---from command line---
 uf=LC & " " & L
 ---end from command line---
 
 End Function

Если есть синтаксическая ошибка, в файле Filter будут отображаться детали отладки.

1 Dim gU
 2 Dim gdU
 3 Set greU = CreateObject("Scripting.Dictionary")
 4 Function UF(L, LC)
 5 On Error Resume Next
 6 uf=LC dim & " " & L
 7 End Function
 
 Error 1025 Expected end of statement
 Line 6 Col 6
 
1 Dim gU
 2 Dim gdU
 3 Set greU = CreateObject("Scripting.Dictionary")
 4 Function UF(L, LC)
 5 On Error Resume Next
 6 uf=LC/0 & " " & L
 7 End Function
 
 Error 11 Division by zero
 Source Microsoft VBScript runtime error
 Line number and column not available for runtime errors

Другие примеры

Переверните каждую строку

filter vbs "uf=StrReverse^(L^)"<"%systemroot%\win.ini"

Список файлов в папке

Иногда бывает необходимо заполучить на лист Excel список файлов в заданной папке и ее подпапках. В моей практике такое встречалось неоднократно, например:

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

Для реализации подобной задачи можно использовать несколько способов.

Способ 1. Скелет из шкафа - функция ФАЙЛЫ

Этот способ использует древнюю функцию ФАЙЛЫ (FILES), оставшуюся в Microsoft Excel с далеких девяностых. Вы не найдете эту функцию в общем списке функций, но для совместимости, она всё ещё остаётся внутри движка Excel, и мы вполне можем её использовать.

Механизм таков:

1. В любую ячейку листа (например, в А1) введём путь к папке, список файлов из которой мы хотим получить.


Обратите внимание, что путь должен оканчиваться шаблоном со звездочками:

  • *.* - любые файлы
  • *.xlsx - книги Excel (только с расширением xlsx)
  • *.xl* - любые файлы Excel
  • *отчет* - файлы, содержащие слово отчет в названии

и т.д.

2. Создадим именованный диапазон с помощью вкладки Формулы - далее кнопка Диспетчер имен - Создать (Formulas - Names Manger - Create). В открывшемся окне введем любое имя без пробелов (например Мои_файлы) и в поле диапазона выражение:

=ФАЙЛЫ(Лист1!$A$1)


После нажатия на ОК будет создан именованный диапазон с именем Мои_файлы, где хранится список всех файлов из указанной в А1 папки. Останется их оттуда только извлечь.

3. Чтобы извлечь имена отдельных файлов из созданной переменной, используем функцию ИНДЕКС (INDEX), которая в Excel вытаскивает данные из массива по их номеру:

Если лениво делать отдельный столбец с нумерацией, то можно воспользоваться костылем в виде функции СТРОКИ (ROWS), которая будет подсчитывать количество заполненных строк с начала списка автоматически:

=ИНДЕКС(Мои_файлы; ЧСТРОК($B$3:B3))

Ну, и скрыть ошибки #ССЫЛКА! в конце списка (если вы протягиваете формулу с запасом) можно стандартной функцией ЕСЛИОШИБКА (IFERROR):

=ЕСЛИОШИБКА(ИНДЕКС(Мои_файлы; ЧСТРОК($B$3:B3)); "")

Важное примечание: формально функция ФАЙЛЫ относится к макро-функциям, поэтому необходимо будет сохранить ваш файл в формате с поддержкой макросов (xlsm или xlsb).

Способ 2. Готовый макрос для ленивых

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

Для добавления макроса в вашу книгу нажмите сочетание клавиш Alt+F11, или кнопку Visual Basic на вкладке Разработчик (Developer), в открывшемся окне редактора Visual Basic вставьте новый модуль через меню Insert - Module и скопируйте туда текст этого макроса: 

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 = 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

Для запуска макроса нажмите сочетание клавиш Alt+F8,или кнопку Макросы (Macros) на вкладке Разработчик (Developer), выберите наш макрос FileList и нажмите кнопку Выполнить (Run). В диалоговом окне выберите любую папку или диск и - вуаля!

Если захотите, чтобы вместо пути к файлу в столбце B выводилась живая гиперссылка, то замените 52-ю строку

Cells(r, 2).Formula = FileItem.Path

на

Cells(r, 2).Formula = "=HYPERLINK(""" & FileItem.Path & """)"

Способ 3. Мощь и красота - надстройка Power Query

Power Query - это очень мощная и при этом бесплатная надстройка для Excel от Microsoft, упрощающая множество задач по загрузке и трансформации данных. В нашей ситуации она тоже может здорово помочь.

Если у вас Excel 2016 или новее, то Power Query уже встроена в Excel по умолчанию, поэтому просто на вкладке Данные выберите команду Создать запрос / Получить данные - Из файла - Из папки (Create Query / Get Data - From file - From folder). Если у вас Excel 2010-2013, то Power Query нужно будет скачать с сайта Microsoft и установить как отдельную надстройку и она появится у вас в Excel в виде отдельной вкладки Power Query. На ней будет аналогичная кнопка Из файла - Из папки (From file - From folder).

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


Если внешний вид списка вас устраивает, то можно смело жать внизу кнопку Загрузить (Load), чтобы залить эти данные на новый лист. Если же хочется дополнительно обработать список (удалить лишние столбцы, отобрать только нужные файлы и т.п.), то нужно выбрать команду Изменить / Преобразовать данные (Edit / Transform Data).

Поверх окна Excel откроется окно редактора Power Query, где мы увидим список всех наших файлов в виде таблицы:


Дальше возможны несколько вариантов:

  • Если нужны только файлы определенного типа, то их можно легко отобрать с помощью фильтра по столбцу Extension:

  • Аналогичным образом фильтрами по столбцам Date accessed, Date modified или Date created можно отобрать файлы за нужный период (например, созданные только за последний месяц и т.п.):

  • Если нужно получить данные не из всех папок, то фильтруем по столбцу Folder Path, чтобы оставить только те строки, где путь содержит/не содержит нужные имена папок:

  • Там же можно выполнить сортировку файлов по любому столбцу, если требуется.

После того, как необходимые файлы отобраны, можно смело удалить ненужные столбцы, щелкнув по заголовку столбца правой кнопкой мыши и выбрав команду Удалить (Remove column). Это, кстати, уже никак не повлияет на фильтрацию или сортировку нашего списка:

Если в будущем планируется подсчитывать количество файлов в каждой папке (например, для контроля поступивших заявок или подсчета статистики по заявкам), то имеет смысл дополнительно сделать ещё пару действий:

  • Щелкните правой кнопкой мыши по столбцу Folder Path и выберите команду Дублировать столбец (Duplicate Column).
  • Выделите скопированный столбец и на вкладке Преобразование (Transform) выберите Разделить столбец - По разделителю (Split Column - By delimiter)

Мы получим рядом с нашими данными еще несколько столбцов, где будут продублированы имена вложенных папок - это пригодится нам чуть позже для подсчета статистики с помощью сводной таблицы:

Получившиеся столбцы можно переименовать (Диск, Папка1, Папка2 и т.д.), просто щёлкнув дважды по заголовку каждого.

И, наконец, когда список готов, то его можно выгрузить на лист с помощью команды Главная - Закрыть и загрузить - Закрыть и загрузить в... (Home - Close & Load - Close & Load to...):

И, само-собой, теперь можно построить по нашей таблице сводную (вкладка Вставка - Сводная таблица), чтобы легко подсчитать количество файлов в каждой папке:

Дополнительным бонусом можно сделать еще один столбец с функцией ГИПЕРССЫЛКА (HYPERLINK), которая создаст красивые стрелочки-ссылки для моментального перехода к каждому файлу:


Мелочь, а приятно :)

И вдвойне приятно, что в будущем, при изменении содержимого исходной папки, достаточно будет просто щелкнуть мышью по нашей таблице и выбрать команду Обновить (Refresh) - и Power Query выполнит всю цепочку запрограммированных нами единожды действий уже автоматически, отобразив все изменения в составе папки.

Ссылки по теме

 

Loop Through Folders - применять макрос ко всем файлам

Я пытаюсь перебрать папки с помощью кода VBA. Находится здесь: Перебрать все подпапки с помощью VBA.

Код, который я просто скопировал и добавил свой собственный макрос. Хотя это не дает ошибки. Код не работает. Он просто не отвечает, когда я запускаю макрос.

У меня есть 500+ файлов, к которым нужно применить макрос - некоторые файлы действительно глубоко вложены в папки.

Я действительно был бы признателен за помощь в создании рабочего макроса. Те, что найдены при обмене стека - либо выдают ошибку, либо просто не отвечают.

Если у кого-либо есть рабочая версия кода с включенным макросом, представленная здесь - это было бы очень полезно.

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

Указывать мне на другие темы мне не помогает - я прочитал все темы. Я потратил время на их тестирование.

Это то, что мне нужно:

- Найти файл определенного типа, т.е. docx, в папке> SubFolder > Sub Folder - применить к нему свой собственный макрос

Найдена версия 1 на стеке:

Sub NewFolder() Dim FileSystem As Object Dim HostFolder As String HostFolder = "C:\Users\Shana\Desktop 2\Folder1\" Set FileSystem = CreateObject("Scripting.FileSystemObject") DoFolder FileSystem.GetFolder(HostFolder) End Sub Sub DoFolder(Folder) Dim SubFolder For Each SubFolder In Folder.SubFolders DoFolder SubFolder Next Dim File For Each File In Folder.Files ActiveDocument.Range.Text = "Replaced" ' Operate on each file Next End Sub

Я просмотрел другой VBA Loop, хотя код папок. Я не смог заставить их работать.

Код, когда я создаю макрос в редакторе VBA, просто не работает.

Версия 2 Найдена на стеке обмена:

Function GetFilesIn(Folder As String) As Collection Dim F As String Set GetFilesIn = New Collection F = Dir(Folder & "\*") Do While F <> "" GetFilesIn.Add F F = Dir Loop End Function Function GetFoldersIn(Folder As String) As Collection Dim F As String Set GetFoldersIn = New Collection F = Dir(Folder & "\*", vbDirectory) Do While F <> "" If GetAttr(Folder & "\" & F) And vbDirectory Then GetFoldersIn.Add F F = Dir Loop End Function Sub Test() Dim C As Collection, F Debug.Print Debug.Print "Files in C:\" Set C = GetFilesIn("C:\Users\Shana\Desktop 2\Folder1\") For Each F In C Debug.Print F Next F Debug.Print Debug.Print "Folders in C:\" Set C = GetFoldersIn("C:\Users\Shana\Desktop 2\Folder1\") For Each F In C ActiveDocument.Range.Text = "Replaced" 'Debug.Print F Next F End Sub

Выше также не работает - я делаю что-то не так?

Это то, что мне нужно:

- Найти файл определенного типа, т.е. docx, в папке> SubFolder > Sub Folder - применить к нему свой собственный макрос

Пожалуйста, не отмечайте как дубликаты, так как мне нужна рабочая версия кода VBA для циклического перебора всех моих файлов docx.

Запуск макроса по всем файлам - SolidWorks

Sub main()

Dim swApp As SldWorks.SldWorks

Dim Part As Object

Dim pPartName As String

Dim longstatus As Long, longwarnings As Long

'Необходима ссылка на библиотеку Microsoft Scripting Runtime (scrrun.dll)

Dim fso As Scripting.FileSystemObject, f As Scripting.Folder

Dim fileList As Files, fileSelect As File

Dim boolstatus As Boolean

Set swApp = Application.SldWorks

Set fso = CreateObject("Scripting.FileSystemObject")

Set f = fso.GetFolder("C:\Мои чертежи") 'Ваша папка

Set fileList = f.Files

For Each fileSelect In fileList

'открыть файл детали

Set Part = swApp.OpenDoc6(fileSelect, swDocPART, 0, "", longstatus, longwarnings)

'If Part Is Nothing Then Exit Sub

Set swModel = swApp.ActiveDoc

boolstatus = swModel Is Nothing

If boolstatus = False Then

'выполнить макрос

'swApp.RunMacro filePathName, ModuleName, ProcedureName

swApp.RunMacro "C:\Macros.swp", "ModuleMacros", "Main"

'сохранить файл

Part.Save2 False

Set Part = Nothing

'закрыть файл

swApp.CloseDoc fileSelect

End If

Next

End Sub

Вот позволил себе немного отредактировать макрос от Kelny. Теперь макрос работает даже если в папке есть не только детали *.sldprt

Как открыть все рабочие книги в папке

Автор Дмитрий Якушев На чтение 2 мин. Просмотров 1.2k.

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

Как макрос работает

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

Код макроса

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

Как работает этот код

  1. Объявляем переменную MyFiles (тип строчный), которая будет фиксировать имя каждого файла.
  2. В шаге 2, макрос использует функцию DIR, чтобы указать Тип файла и адрес папки. Обратите внимание, что код ищет файлы в формате xlsx. Это означает, что только .xlsx файлы будут передаваться. Если вы ищете .xls файлы, вам необходимо изменить расширение.
  3. Открываем файл, делаем некоторые действия (вы должны поместить в код макроса требуемые действия), а затем мы сохраняем и закрываем файл. В этом простом примере, мы вызываем окно с сообщением, чтобы показать имя каждого файла.
  4. Ищем снова по кругу, чтобы найти больше файлов. Если нет файлов, переменная MyFiles пустая.
    Если это так, то цикл и макрос завершается.

Как использовать

Для реализации этого макроса, вы можете скопировать и вставить его в стандартный модуль:

  1. Активируйте редактор Visual Basic, нажав ALT + F11.
  2. Щелкните правой кнопкой мыши имя проекта / рабочей книги в окне проекта.
  3. Выберите Insert➜Module.
  4. Введите или вставьте код во вновь созданном модуле.

Как получить список файлов в Excel с помощью VBA

Специально для примера я создал папку, в которой разместил несколько файлов различных типов и две подпапки. Вот так они выглядят:

 

Давайте рассмотрим несколько способов получения списка файлов.

Способ 1. Использование функции Dir

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

Вот там код данной функции, который выводит на лист 1 перечень файлов.


 '**************************************************************
 ' Sub : ExampleOne
 ' Author : Алексей Желтов
 ' Date : 15.06.2020
 ' Purpose : Вывод всех файлов в папке на лист
 '**************************************************************
 Sub ExampleOne()
 
 Dim Sh As Worksheet
 Dim Folder As String
 Dim FileName As String
 Dim i As Long
 
 Set Sh = ThisWorkbook.Sheets(1)
 Folder = Sh.Cells(3, 2)
 
 ' Проверка корректности введенных данных
 If PathExists(Folder) = False Then
 MsgBox "Указанной папки не существует", 16, "Ошибка исходных данных"
 Exit Sub
 End If
 
 ' Удаляем содержимое
 Sh.Rows("7:" & Sh.Range("A7").End(xlDown).Row).Delete Shift:=xlUp
 
 i = 7
 FileName = Dir(Folder & "/", vbNormal)
 Do While FileName <> ""
 Sh.Cells(i, 1) = i - 6
 Sh.Cells(i, 2) = FileName
 i = i + 1
 
 ' переход к следующему файлу
 FileName = Dir
 Loop
 
 End Sub

Тут мы проверяем существование папки с помощью дополнительной функции. Опять таки не используем сторонних библиотек, а используем туже функцию Dir.


 '**************************************************************
 ' Function : PathExists
 ' Author : Алексей Желтов
 ' Date : 15.06.2020
 ' Purpose : Возвращает ИСТИНА если путь pname существует
 '**************************************************************
 Private Function PathExists(pname As String) As Boolean
 On Error Resume Next
 If Dir(pname, vbDirectory) = "" Then
 PathExists = False
 Else
 PathExists = (GetAttr(pname) And vbDirectory) = vbDirectory
 End If
 End Function

Вот так выглядит результат работы функции. Программа записала список файлов на текущий лист Excel.

Здесь мы не делали проверку на тип файла и вывели все файлы которые у нас были. 

Если же необходимо отобрать только определенные типы файлов, например Excel файлы, то в нашем коде необходимо сделать дополнительную проверку:


 Do While FileName <> ""
 
 If LCase(FileName) Like "*xls*" Then
 Sh.Cells(i, 1) = i - 6
 Sh.Cells(i, 2) = FileName
 i = i + 1
 End If
 ' переход к следующему файлу
 FileName = Dir
 Loop

Знак "*" означает любой набор символов. Таким образом, мы учли различные версии файлов Excel (xls, xlsx, xlsm).

Способ 2. Используем объект FileSystemObject

В данном случае мы будем не просто получать названия файлов, но также определять тип файла, получать его размер и дату создания. Для этого нам потребуется использовать объект FileSystemObject. Он предоставляет нам сведения о файловой системе компьютера.

Однако, чтобы начать его использовать придется подключить одну библиотеку. Не пугайтесь, она есть на всех компьютерах с Windows, потому скачивать ничего не придется. Чтобы подключить ее необходимо:

  1. Открыть пункт меню Tools и выбрать пункт References.
  2. Выбрать ссылку на библиотеку Microsoft Scripting Runtime. 
  3. Нажать Ок.

Теперь перейдем к коду. Он немного упростился:


 '**************************************************************
 ' Sub : ExampleTwo
 ' Author : Алексей Желтов
 ' Date : 15.06.2020
 ' Purpose : Вывод всех файлов в папке на лист
 '**************************************************************
 Sub ExampleTwo()
 
 Dim Sh As Worksheet
 Dim FSO As New FileSystemObject
 Dim FolderPath As String
 Dim MyFolder As Folder
 Dim iFile As File
 Dim i As Long
 
 Set Sh = ThisWorkbook.Sheets(2)
 FolderPath = Sh.Cells(3, 2)
 
 ' Проверка корректности введенных данных
 If Not FSO.FolderExists(FolderPath) Then
 MsgBox "Указанной папки не существует", 16, "Ошибка исходных данных"
 Exit Sub
 End If
 
 ' Удаляем содержимое
 Sh.Rows("7:" & Sh.Range("A7").End(xlDown).Row).Delete Shift:=xlUp
 
 Set MyFolder = FSO.GetFolder(FolderPath)
 
 i = 7
 For Each iFile In MyFolder.Files
 Sh.Cells(i, 1) = i - 6
 Sh.Cells(i, 2) = iFile.Name
 Sh.Cells(i, 3) = iFile.Type
 Sh.Cells(i, 4) = iFile.DateCreated
 Sh.Cells(i, 5) = iFile.Size
 i = i + 1
 Next
 
 End Sub

Обратите внимание на переменные. Переменная FSO - это новый экземпляр объекта FileSystemObject. Тут мы его объявляем и сразу создаем. Директива New очень важна, многие тут допускают ошибку. Также создаем объекты MyFolder и iFile - это тоже объекты FileSystemObject


 Dim Sh As Worksheet
 Dim FSO As New FileSystemObject ' объявляем и создаем новый экземпляр объекта 
 Dim FolderPath As String
 Dim MyFolder As Folder
 Dim iFile As File
 Dim i As Long

Далее делаем проверку на существование папки. В данном случае нам не нужна дополнительная функция , мы пользуемся методом FolderExists объекта (класса) FileSystemObject.

Ну и остается аналогично перебрать все файлы в директории. Тут удобно использовать цикл For Each - Next.


 For Each iFile In MyFolder.Files
 Sh.Cells(i, 1) = i - 6
 Sh.Cells(i, 2) = iFile.Name ' название файла
 Sh.Cells(i, 3) = iFile.Type ' тип файла
 Sh.Cells(i, 4) = iFile.DateCreated ' дата создания
 Sh.Cells(i, 5) = iFile.Size ' размер
 i = i + 1
 Next

Результат работы программы следующий:

Способ 3. Создаем функцию, которая возвращает файлы в папке и подпапках

Напоследок разберем функцию, которая будет возвращать нам все файлы в текущей папке и во вложенных папках. Вообще это универсальная функция, которая подойдет на все случаи жизни. Смело копируйте ее в свой проект! 

Итак перейдем к коду:


 '**************************************************************
 ' Function : GetFiles
 ' Author : Алексей Желтов
 ' Date : 15.06.2020
 ' Purpose : Получение файлов из папок и подпапок
 '**************************************************************
 Public Function GetFiles(ByVal Path As String, Optional ByVal Filter As String = "*", Optional ByVal Nesting As Long = 100) As Collection
 Dim MainFolder As Folder
 Dim iFolder As Folder
 Dim iFile As File
 Dim FSO As New FileSystemObject
 Dim MainColl As New Collection
 Dim iColl As Collection
 Dim spltFilter() As String
 Dim i As Long
 
 Set MainFolder = FSO.GetFolder(Path)
 If MainFolder Is Nothing Then Exit Function
 spltFilter = Split(Filter, ",")
 
 ' Перебираем файлы
 For Each iFile In MainFolder.Files
 ' Игнорируем временные файлы
 If InStr(1, iFile.Name, "~") = 0 Then
 ' Проверяем фильтры файлов
 For i = 0 To UBound(spltFilter)
 If LCase(iFile.Name) Like "*" & LCase(spltFilter(i)) Then
 MainColl.Add iFile, iFile.Path
 End If
 Next
 End If
 Next
 
 ' Перебираем вложенные папки
 If Nesting > 0 Then
 For Each iFolder In MainFolder.SubFolders
 ' рекурсивный вызов функции
 Set iColl = GetFiles(iFolder.Path, Filter, Nesting - 1)
 
 'добавляем файлы из вложенных папок
 For i = 1 To iColl.Count
 MainColl.Add iColl(i), iColl(i).Path
 Next
 Next
 End If
 
 Set GetFiles = MainColl
 End Function

Разберем основные моменты этой функции. На вход она принимает один обязательный аргумент - это путь к папке Path. Также может принимать два необязательных параметра:

  • Filter - перечисление списка файлов, которые мы хотим получить. Перечислять необходимо через запятую, например "doc, xls*". Вы можете использовать символ "*" чтобы включить сравнение по шаблону. По умолчанию фильтр отсутствует и возвращаются все типы файлов.
  • Nesting - вложенность. Это максимальное число вложенных папок в которые "проваливается" алгоритм. По умолчанию равно 100.

В целом по алгоритму комментарии лишние, все должно быть понятно. Основной момент хочу обратить на строку 38.


 For Each iFolder In MainFolder.SubFolders
 ' рекурсивный вызов функции
 Set iColl = GetFiles(iFolder.Path, Filter, Nesting - 1)
 
 'добавляем файлы из вложенных папок
 For i = 1 To iColl.Count
 MainColl.Add iColl(i), iColl(i).Path
 Next
 Next

Тут мы рекурсивно вызываем эту же функцию. Т.е. получается что функция вызывает саму себя. И это происходит до тех пор пока либо не останется вложенных папок, либо не будет достигнут желаемый уровень вложенности.

Теперь когда наша функция готова, просто используем ее где нам требуется вот так:


 '**************************************************************
 ' Sub : ExampleThree
 ' Author : Алексей Желтов
 ' Date : 15.06.2020
 ' Purpose : Вывод всех файлов в папке на лист
 '**************************************************************
 Sub ExampleThree()
 
 Dim Sh As Worksheet
 Dim FolderPath As String
 Dim iFile As File
 Dim i As Long
 Dim Coll As Collection
 Dim FSO As New FileSystemObject
 
 Set Sh = ThisWorkbook.Sheets(3)
 FolderPath = Sh.Cells(3, 2)
 
 Set Coll = GetFiles(FolderPath)
 
 For i = 1 To Coll.Count
 Set iFile = Coll(i)
 Sh.Cells(i + 6, 1) = i
 Sh.Cells(i + 6, 2) = iFile.Name
 Sh.Cells(i + 6, 3) = FSO.GetFolder(iFile.ParentFolder).Name
 Sh.Cells(i + 6, 4) = iFile.Type
 Sh.Cells(i + 6, 5) = iFile.DateCreated
 Sh.Cells(i + 6, 6) = iFile.Size
 Next
 
 End Sub

Функция нам возвращает коллекцию файлов в папке и подпапках. Вот так:

Пример файлы можете скачать по кнопке ниже и использовать в своей работе. Оставляйте комментарии, буду рад на них ответить.

Скачать

рекурсия - Применение макроса ко всем файлам в папке

Переполнение стека
  1. Около
  2. Продукты
  3. Для команд
  1. Переполнение стека Общественные вопросы и ответы
  2. Переполнение стека для команд Где разработчики и технологи делятся частным
.

excel - Как запустить макрос для всех файлов в папке?

Переполнение стека
  1. Около
  2. Продукты
  3. Для команд
  1. Переполнение стека Общественные вопросы и ответы
  2. Переполнение стека для команд Где разработчики и технологи делятся частными знаниями с коллегами
  3. Вакансии Программирование и связанные с ним технические возможности карьерного роста
  4. Талант Нанимайте технических специалистов и создавайте свой бренд работодателя
  5. Реклама Обратитесь к разработчикам и технологам со всего мира
  6. О компании
.

Применить функцию из определенного пакета R ко всем файлам в папке

Переполнение стека
  1. Около
  2. Продукты
  3. Для команд
  1. Переполнение стека Общественные вопросы и ответы
  2. Переполнение стека для команд Где разработчики и технологи делятся частными знаниями с коллегами
  3. Вакансии Программирование и связанные с ним технические возможности карьерного роста
  4. Талант Нанимайте технических специалистов и создавайте свой бренд работодателя
.

В clojure, как применить макрос к списку?

Переполнение стека
  1. Около
  2. Продукты
  3. Для команд
  1. Переполнение стека Общественные вопросы и ответы
  2. Переполнение стека для команд Где разработчики и технологи делятся частными знаниями с коллегами
  3. Вакансии Программирование и связанные с ним технические возможности карьерного роста
  4. Талант Нанимайте технических специалистов и создавайте свой бренд работодателя
  5. Реклама Обратитесь к разработчикам и технологам со всего мира
  6. О компании
.Каталог

- макрос Excel для удаления определенного столбца из всех файлов в папке

Переполнение стека
  1. Около
  2. Продукты
  3. Для команд
  1. Переполнение стека Общественные вопросы и ответы
  2. Переполнение стека для команд Где разработчики и технологи делятся частными знаниями с коллегами
.

Смотрите также