我分享我的代码列出所有子目录和文件包含在一个选定的文件夹或ZIP存档。
我一直在寻找这样的解决方案几天，只发现有缺陷的递归脚本，停止在列出第一个子文件夹的内容，或在根文件夹中丢失的文件，或只为2级子文件夹工作。
此脚本使用在工作表中列出找到的项目，将它们标记为目录或文件，以便它可以遍历这些项目，并在遍历过程中重新启动所有新找到的子文件夹级别的浏览功能。
它使用shell应用程序而不是DIR，因此它也可以用于搜索zip存档的内容（Dir功能将ZIP视为文件，而不是目录）
我已经尽可能地精简了它，但如果您能进一步简化它，我会非常高兴

Sub loop_through_files_in_subfolders()

Dim wb As Workbook
Dim ws As Worksheet

Dim start_folder As Variant

Dim LastRow As Long
Dim CurrRow As Long

Set wb = ThisWorkbook
Set ws = wb.Worksheets(1)

'set folder of choice or zip archive
start_folder = "C:\Makro_test\F1.zip"

'sets the selected path in colum A as initial directory and sets "D"irectory flag in column B
ws.Range("A2").Value2 = start_folder
ws.Range("B2").Value2 = "D"

'set current row as first under headers
CurrRow = 2

'set last row as first empty row
LastRow = 3

'continue until current row equals the first empty row (list has ended)
Do Until CurrRow = LastRow

'only do for rows containing a "D"irectory path
If ws.Range("B" & CurrRow).Value2 = "D" Then
    
    start_folder = ws.Range("A" & CurrRow).Value2 'set the folder to look through
    loop_through_items_in_folder start_folder, wb, ws 'execute the look through function
    ws.Range("A" & CurrRow).Interior.ColorIndex = 37 'colour mark the cell containing searched folder

End If

CurrRow = CurrRow + 1 'set current row to next one

'update last row to include contents of the last searched folder
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1

Loop

End Sub

Function loop_through_items_in_folder(ITM_path As Variant, wb, ws)

Dim shell
Dim ITM, Sub_ITM

Dim LR As Long

Set shell = CreateObject("Shell.Application")

'use the provided path to set the folder
Set ITM = shell.Namespace(ITM_path)

'loop through all items in folder
For Each Sub_ITM In ITM.items

    'look for first empty row
    LR = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
    
    'store file path in column A
    ws.Range("A" & LR).Value = Sub_ITM.path
    
    'store flag for "D"irectory or "F"ile in column B
    If Sub_ITM.isfolder Then
        ws.Range("B" & LR).Value = "D"
    Else
        ws.Range("B" & LR).Value = "F"
    End If

Next Sub_ITM

End Function