Option Explicit
Public colFolders As New Collection
Public colFiles As New Collection
Sub Кнопка1_Найти_Добавить()
Dim path As String, File As String, arg As String, i As Long, strFileMask$, fld, fl
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Укажите рабочую папку": .Show
If .SelectedItems.Count = 0 Then
Exit Sub
Else
path = .SelectedItems(1) & "\"
End If
End With
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
strFileMask = "*" & CStr(ActiveSheet.Range("A2").Value) & "*.xlsm" ' маска для целевых файлов
Call get_folders_col(path) ' создаём коллекцию директорий с вложенными папками
For Each fld In colFolders ' цикл по коллекции директорий
Call get_files_col(fld, strFileMask) ' создаём коллекцию целевых файлов из указанной папки и подпапок
Next fld
Set colFolders = Nothing ' очищаем коллекцию папок (уже не нужна)
i = Rows(Rows.Count).End(xlUp).Row + 1
For Each fl In colFiles ' цикл по коллекции файлов
File = Split(fl, "\")(UBound(Split(fl, "\"))) ' из полного имени файла берём только имя файла
path = Left(fl, Len(fl) - Len(File)) ' путь из полного имени файла
Debug.Print "'" & path & "[" & File & "]" & "Данные'!" & Range("D1").Range("A1").Address(, , xlR1C1)
Cells(i, 1) = ExecuteExcel4Macro("'" & path & "[" & File & "]" & "Данные'!" & Range("D1").Range("A1").Address(, , xlR1C1)) '№ заказа
Cells(i, 3) = ExecuteExcel4Macro("'" & path & "[" & File & "]" & "Данные'!" & Range("A4").Range("A1").Address(, , xlR1C1)) 'материал
Cells(i, 4) = ExecuteExcel4Macro("'" & path & "[" & File & "]" & "Данные'!" & Range("B4").Range("A1").Address(, , xlR1C1)) 'наименование
Cells(i, 5) = ExecuteExcel4Macro("'" & path & "[" & File & "]" & "Данные'!" & Range("C4").Range("A1").Address(, , xlR1C1)) 'оборудование
Cells(i, 7) = ExecuteExcel4Macro("'" & path & "[" & File & "]" & "Данные'!" & Range("D4").Range("A1").Address(, , xlR1C1)) 'параметр1
Cells(i, 8) = ExecuteExcel4Macro("'" & path & "[" & File & "]" & "Данные'!" & Range("E4").Range("A1").Address(, , xlR1C1)) 'параметр2
Cells(i, 9) = ExecuteExcel4Macro("'" & path & "[" & File & "]" & "Данные'!" & Range("F4").Range("A1").Address(, , xlR1C1)) 'кол-во
Cells(i, 10) = ExecuteExcel4Macro("'" & path & "[" & File & "]" & "Данные'!" & Range("K4").Range("A1").Address(, , xlR1C1)) 'упаковка
i = i + 1
Next fl
Set colFiles = Nothing ' очищаем коллекцию файлов (уже не нужна)
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Sub get_folders_col(SFold$)
'Объявляем переменные
Dim FSO As Object, Folder As Object, SubFolder As Object, sFlds$ ', tsOut
colFolders.Add SFold
'Создаем объект FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
'Создаем файл, куда будем записывать имена подкаталогов
'Путь к корневому каталогу
Set Folder = FSO.GetFolder(SFold)
'Цикл по всем подкаталогам
For Each SubFolder In Folder.SubFolders
sFlds = SFold & "\" & SubFolder.Name
'Выводим полученные строки в файл output.txt
Call get_folders_col(sFlds)
Next SubFolder
Set FSO = Nothing
Set Folder = Nothing
Set SubFolder = Nothing
sFlds = ""
End Sub
Sub get_files_col(SFold, SMaskF$)
'Объявляем переменные
Dim FSO As Object, Folder As Object, File As Object, s_FPath$ '
'Создаем объект FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
'Путь к корневому каталогу
Set Folder = FSO.GetFolder(SFold)
'Цикл по всем файлам
For Each File In Folder.Files
s_FPath = File.path
If s_FPath Like SMaskF Then colFiles.Add s_FPath
Next File
Set FSO = Nothing
Set Folder = Nothing
Set File = Nothing
End Sub |