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

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

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

Sub FileAndFolder()

Dim FSOLibrary As Object
Dim FSOFolder As Object
Dim FolderName As String
Dim FilesTbl As ListObject
Set FilesTbl = Range("FilesTbl").ListObject

'Set the folder name to a variable
FolderName = Left$(ActiveWorkbook.Path, InStrRev(ActiveWorkbook.Path, "\"))

'Set the reference to the FSO Library
Set FSOLibrary = CreateObject("Scripting.FileSystemObject")

'Another Macro must call LoopAllSubFolders Macro to start
LoopAllFolders FSOLibrary.GetFolder(FolderName)

'return TempArray here and paste into table

'Range(FilesTbl.ListColumns("File Name").DataBodyRange(1)) = TempArray

End Sub

Sub LoopAllFolders(FSOFolder As Object)
'Don’t run the following macro, it will be called from the macro above

Dim FSOSubFolder As Object
Dim FSOFile As Object
Dim FolderPath As String
Dim FileName As String
Dim TempArray() As String

'For each subfolder call the macro
For Each FSOSubFolder In FSOFolder.SubFolders
    LoopAllFolders FSOSubFolder
Next

'For each file, print the name
For Each FSOFile In FSOFolder.Files

    'Insert the actions to be performed on each file
    FileName = FSOFile.Name
    FolderPath = FSOFile.ParentFolder
          
    If Left(FileName, 2) = "~$" Then GoTo NEXTINLOOP
    ReDim Preserve TempArray(0 To 3, 0 To i)
        
    TempArray(0, i) = FileName
    TempArray(1, i) = FolderPath & "\" & FileName 'file
    TempArray(2, i) = FolderPath 'folder
    TempArray(3, i) = FolderPath & "\" & FileName 'showpath
        
    i = i + 1
NEXTINLOOP:
Next
 
End Sub 'TempArray and i clears here

Спасибо.

0
Robert Hall 13 Ноя 2020 в 12:09

2 ответа

Лучший ответ

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

Функция, приведенная ниже, вернет вариант, содержащий массив массивов (обычно называемый зазубренным массивом). Вы получаете доступ к зубчатому массиву, используя эту номенклатуру

Varname(x)(y)

Вам понадобится переменная в вызывающем методе, чтобы получить зубчатый массив

Например

Dim myFileInfo as Variant
MyFileInfo = LoopAllFolders(FSOLibrary.GetFolder(FolderName))

Вот обновленная функция

Public Function LoopAllFolders(FSOFolder As Scripting.FileSystemObject) As Variant
'Don’t run the following macro, it will be called from the macro above

    Dim FileInfo As Scripting.Dictionary: Set myFileInfo = New Scripting.Dictionary

'For each subfolder call the macro

    Dim FSOSubFolder As Scripting.Folder
    For Each FSOSubFolder In FSOFolder.SubFolders
        LoopAllFolders FSOSubFolder
    Next

    'For each file, print the name
    Dim FSOFile As Scripting.File
    For Each FSOFile In FSOFolder.Files

        'Insert the actions to be performed on each file
        Dim FileName As String
        FileName = FSOFile.Name
    
        Dim FolderPath As String
        FolderPath = FSOFile.ParentFolder
          
        If Not Left(FileName, 2) = "~$" Then
    
            myFileInfo.Add Array(FileName, FolderPath & "\" & FileName, FolderPath, FolderPath & "\" & FileName)
        
        End If
    
    Next

    LoopAllFolders = myFileInfo.Items
 
End Function

Приведенный выше код может быть не идеальным, но, по крайней мере, он указывает вам правильное направление.

Основываясь на вашем вопросе, вы могли бы преуспеть, проработав руководство по VBA, поскольку функции довольно фундаментальны, и если вы о них не знаете ...

Чтобы помочь вам в вашем путешествии, я также рекомендую установить фантастический и бесплатный надстройку RubberDuck.

1
freeflow 13 Ноя 2020 в 10:10

Создать список файлов все подпапки папки

  • Я не понимаю, что вы делаете с FilesTbl, поэтому я изменил ваше решение, чтобы создать новую книгу с результатом. Наверняка вы разберетесь, как его нанести на стол.

Быстрое решение

Option Explicit

Sub FileAndFolder()

    Dim FSOLibrary As Object
    Dim FSOFolder As Object
    Dim FolderName As String
    Dim FilesTbl As ListObject
    'Set FilesTbl = Range("FilesTbl").ListObject
    
    'Set the folder name to a variable
    FolderName = Left$(ActiveWorkbook.Path, InStrRev(ActiveWorkbook.Path, "\"))
    
    'Set the reference to the FSO Library
    Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
    
    Dim TempArray() As Variant ' ByRef
    
    'Another Macro must call LoopAllSubFolders Macro to start
    LoopAllFolders FSOLibrary.GetFolder(FolderName), TempArray
    
    'return TempArray here and paste into table
    With Workbooks.Add
        With ActiveSheet.Range("A1").Resize(UBound(TempArray, 2), UBound(TempArray))
            .Value = Application.Transpose(TempArray)
        End With
        .Saved = True
    End With
    
    'Range(FilesTbl.ListColumns("File Name").DataBodyRange(1)) = TempArray

End Sub

Sub LoopAllFolders(FSOFolder As Object, ByRef TempArray As Variant)
'Don’t run the following macro, it will be called from the macro above

    Dim FSOSubFolder As Object
    Dim FSOFile As Object
    Dim FolderPath As String
    Dim FileName As String
    Dim i As Long
    'Dim TempArray() As String
    
    'For each subfolder call the macro
    For Each FSOSubFolder In FSOFolder.SubFolders
        LoopAllFolders FSOSubFolder, TempArray
    Next
    
    'For each file, print the name
    For Each FSOFile In FSOFolder.Files
    
        'Insert the actions to be performed on each file
        FileName = FSOFile.Name
        FolderPath = FSOFile.ParentFolder
              
        If Left(FileName, 2) = "~$" Then GoTo NEXTINLOOP
        i = i + 1
        ReDim Preserve TempArray(1 To 4, 1 To i)
            
        TempArray(1, i) = FileName
        TempArray(2, i) = FolderPath & "\" & FileName 'file
        TempArray(3, i) = FolderPath 'folder
        TempArray(4, i) = FolderPath & "\" & FileName 'showpath
            
NEXTINLOOP:
    Next
 
End Sub 'TempArray and i clears here
0
VBasic2008 13 Ноя 2020 в 10:11