Макрос VBA, который ищет файл в нескольких подпапках

У меня есть макрос, если я помещаю в ячейку E1 имя файла, поиск макроса через C: \ Users \ Marek \ Desktop \ Makro \ directory, найдите его и поместите необходимые значения в определенные ячейки моего исходного файла с помощью макроса.

Возможно ли сделать эту работу без определенного расположения папки? Мне нужно что-то, что можно найти в C: \ Users \ Marek \ Desktop \ Makro \ со многими подпапками.

Мой код:

Sub Zila1() Dim SaveDriveDir As String, MyPath As String Dim FName As Variant Dim YrMth As String SaveDriveDir = CurDir MyPath = Application.DefaultFilePath 'or use "C:\Data" ChDrive MyPath ChDir MyPath FName = Sheets("Sheet1").Range("E1").Text If FName = False Then 'do nothing Else GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _ "A16:A17", Sheets("Sheet1").Range("B2:B3"), True, False GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _ "AE23:AE24", Sheets("Sheet1").Range("B3:B4"), True, False GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _ "AE26:AE27", Sheets("Sheet1").Range("B4:B5"), True, False GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _ "AQ59:AQ60", Sheets("Sheet1").Range("B5:B6"), True, False GetData "C:\Users\Marek\Desktop\Makro\" & FName & ".xls", "Vystupna_kontrola", _ "AR65:AR66", Sheets("Sheet1").Range("B6:B7"), True, False End If ChDrive SaveDriveDir ChDir SaveDriveDir End Sub 

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

 Function Recurse(sPath As String) As String Dim FSO As New FileSystemObject Dim myFolder As Folder Dim mySubFolder As Folder Set myFolder = FSO.GetFolder(sPath) For Each mySubFolder In myFolder.SubFolders Call TestSub(mySubFolder.Path) Recurse = Recurse(mySubFolder.Path) Next End Function Sub TestR() Call Recurse("D:\Projets\") End Sub Sub TestSub(ByVal s As String) Debug.Print s End Sub 

Изменить: вот как вы можете реализовать этот код в своей книге, чтобы достичь своей цели.

 Sub TestSub(ByVal s As String) Dim FSO As New FileSystemObject Dim myFolder As Folder Dim myFile As File Set myFolder = FSO.GetFolder(s) For Each myFile In myFolder.Files If myFile.Name = Range("E1").Value Then Debug.Print myFile.Name 'Or do whatever you want with the file End If Next End Sub 

Здесь я просто отлаживаю имя найденного файла, остальное зависит от вас. 😉

Конечно, некоторые говорили бы, что немного сложно назвать дважды FileSystemObject, чтобы вы могли просто написать свой код, как это (в зависимости от того, какой вы хотите разделить или нет):

 Function Recurse(sPath As String) As String Dim FSO As New FileSystemObject Dim myFolder As Folder Dim mySubFolder As Folder Dim myFile As File Set myFolder = FSO.GetFolder(sPath) For Each mySubFolder In myFolder.SubFolders For Each myFile In mySubFolder.Files If myFile.Name = Range("E1").Value Then Debug.Print myFile.Name & " in " & myFile.Path 'Or do whatever you want with the file Exit For End If Next Recurse = Recurse(mySubFolder.Path) Next End Function Sub TestR() Call Recurse("D:\Projets\") End Sub 

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

 Sub GetFiles(StartFolder As String, Pattern As String, _ DoSubfolders As Boolean, ByRef colFiles As Collection) Dim f As String, sf As String, subF As New Collection, s If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\" f = Dir(StartFolder & Pattern) Do While Len(f) > 0 colFiles.Add StartFolder & f f = Dir() Loop sf = Dir(StartFolder, vbDirectory) Do While Len(sf) > 0 If sf <> "." And sf <> ".." Then If (GetAttr(StartFolder & sf) And vbDirectory) <> 0 Then subF.Add StartFolder & sf End If End If sf = Dir() Loop For Each s In subF GetFiles CStr(s), Pattern, True, colFiles Next s End Sub 

Применение:

 Dim colFiles As New Collection GetFiles "C:\Users\Marek\Desktop\Makro\", FName & ".xls", True, colFiles If colFiles.Count > 0 Then 'work with found files End If 

Я на самом деле просто нашел это сегодня для чего-то, над чем я работаю. Это вернет пути к файлам для всех файлов в папке и ее подпапках.

 Dim colFiles As New Collection RecursiveDir colFiles, "C:\Users\Marek\Desktop\Makro\", "*.*", True Dim vFile As Variant For Each vFile In colFiles 'file operation here or store file name/path in a string array for use later in the script filepath(n) = vFile filename = fso.GetFileName(vFile) 'If you want the filename without full path n=n+1 Next vFile 'These two functions are required Public Function RecursiveDir(colFiles As Collection, strFolder As String, strFileSpec As String, bIncludeSubfolders As Boolean) Dim strTemp As String Dim colFolders As New Collection Dim vFolderName As Variant strFolder = TrailingSlash(strFolder) strTemp = Dir(strFolder & strFileSpec) Do While strTemp <> vbNullString colFiles.Add strFolder & strTemp strTemp = Dir Loop If bIncludeSubfolders Then strTemp = Dir(strFolder, vbDirectory) Do While strTemp <> vbNullString If (strTemp <> ".") And (strTemp <> "..") Then If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then colFolders.Add strTemp End If End If strTemp = Dir Loop 'Call RecursiveDir for each subfolder in colFolders For Each vFolderName In colFolders Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True) Next vFolderName End If End Function Public Function TrailingSlash(strFolder As String) As String If Len(strFolder) > 0 Then If Right(strFolder, 1) = "\" Then TrailingSlash = strFolder Else TrailingSlash = strFolder & "\" End If End If End Function 

Это адаптировано из сообщения Ammara Digital Image Solutions ( http://www.ammara.com/access_image_faq/recursive_folder_search.html ).

Если это помогает, вы также можете использовать FileSystemObject для извлечения всех подпапок папки. Вам нужно проверить ссылку «Время выполнения сценариев Microsot», чтобы получить Intellisense и использовать «новое» ключевое слово.

 Sub GetSubFolders() Dim fso As New FileSystemObject Dim f As Folder, sf As Folder Set f = fso.GetFolder("D:\Proj\") For Each sf In f.SubFolders 'Code inside Next End Sub 
  • Как можно выделить две отдельные ячейки с разделенными запятыми данными и соединить их?
  • Использование Excel VBA для запуска SQL-запроса
  • Поиск excel с двумя поисковыми словами (множественный поиск) с использованием макроса vba
  • Как увеличить высоту строки в Excel с помощью X. Т.е. Добавить вертикальное заполнение ячейки
  • Самый быстрый способ удалить строки, которые нельзя захватить с помощью SpecialCells
  • Excel VBA Performance - 1 миллион строк - удаление строк, содержащих значение, менее чем за 1 минуту
  • Назначить код кнопке, созданной динамически
  • Как создать отдельный файл CSV из VBA?
  • Vba Excel делает vlookup из закрытого файла
  • Ошибка Excel VBA во время выполнения «32809» - попытка понять
  • Открыть html-страницу в браузере по умолчанию с помощью VBA?
  • Давайте будем гением компьютера.