VBA – запись содержимого папки на рабочий лист

В настоящее время я использую макрос VBA, который предназначен для сбора имен всех подпапок в основной папке и записи их в рабочий лист. Текущий метод заключается в использовании команды Shell для открытия cmd.exe и записи списка в текстовый файл. Затем файл открывается и считывается на рабочий лист:

Sub Button_GetList() Dim RunCommand As String, FolderListPath As String, _ TempFile As String, MainFolder As String TempFile = "foldernames.txt" MainFolder = "simulations" RunCommand = _ "cmd.exe /c dir " & ThisWorkbook.Path & "\" & MainFolder & " /b > " _ ThisWorkbook.Path & "\" & TempFile x = Shell(RunCommand, 1) FolderListPath = ThisWorkbook.Path & "\" & TempFile Close #1 Open FolderListPath For Input As #1 j = 1 Do While Not EOF(1) Line Input #1, TextLine MAIN.Cells(j, 1) = TextLine j = j + 1 Loop Close #1 End Sub 

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

 Application.Wait (Now + TimeValue("0:00:05")) 

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

Да, вы можете получить список программным способом ( Dir$() ), а не запускать внешний процесс;

 Dim lookin As String, directory As String, j As Long lookin = "c:\windows\" directory = Dir$(lookin & "*.*", vbDirectory) j = 1 Do While Len(directory) If directory <> "." And directory <> ".." And GetAttr(lookin & directory) And vbDirectory Then MAIN.Cells(j, 1).Value = directory j = j + 1 End If directory = Dir$() Loop 

вы можете проверить, существует ли файл, например

 x = Shell(RunCommand, 1) 'your code Do DoEvents Loop until Not Dir(ThisWorkbook.Path & "\" & TempFile) = "" FolderListPath = ThisWorkbook.Path & "\" & TempFile Close #1 'your code Open FolderListPath For Input As #1 

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

Использование shell и Dir немного устарело в 1990 году: P

FileSystemObject намного больше OOP'ы. Предположим, ваш предпочтительный выбор.

Ниже вы можете указать глубину рекурсии (0 только для вложенных папок указанной папки,> 0 для указанной глубины вложенных папок (например, 1 для подпапок во всех подпапках) и <0 для полного рекурсирования через дерево каталогов).

 'recursionDepth = 0 for no recursion, >0 for specified recursion depth, <0 for unlimited recursion Private Sub getSubdirectories(parent, subdirectoriesC As Collection, Optional recursionDepth As Integer = 0) Dim subfolder For Each subfolder In parent.subfolders subdirectoriesC.Add subfolder If recursionDepth < 0 Then getSubdirectories subfolder, subdirectoriesC, recursionDepth ElseIf recursionDepth > 0 Then getSubdirectories subfolder, subdirectoriesC, recursionDepth - 1 End If Next subfolder End Sub 

Ниже приведен пример использования

 Sub ExampleCallOfGetSubDirectories() Dim parentFolder, subdirectoriesC As Collection, arr, i As Long Set parentFolder = CreateObject("Scripting.FileSystemObject").GetFolder("your folder path") Set subdirectoriesC = New Collection getSubdirectories parentFolder, subdirectoriesC, 0 'This section is unnecessary depending on your uses 'For this example it just prints the results to the Activesheet If subdirectoriesC.Count > 0 Then ReDim arr(1 To subdirectoriesC.Count, 1 To 1) For i = 1 To UBound(arr, 1) arr(i, 1) = subdirectoriesC(i).Path Next i With ActiveSheet .Range(.Cells(1, 1), .Cells(subdirectoriesC.Count, 1)).Value = arr End With End If End Sub 
Давайте будем гением компьютера.