可遍历文件夹/ZIP含子目录的VBA代码分享及优化问询

我分享一款能列出选定文件夹或ZIP压缩包中所有子目录与文件的VBA代码。之前找同类方案时，发现现有递归脚本存在不少缺陷：要么只能列出第一层子目录内容，要么会遗漏根目录文件，或者仅支持两级子目录。

这款脚本通过在工作表中标记目录（D）或文件（F），循环触发遍历函数来实现多级目录遍历；同时用Shell Application替代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

优化精简建议 #

• 减少工作表重复交互：每次循环调用ws.Cells(ws.Rows.Count, "A").End(xlUp).Row会频繁读写工作表，可改用数组存储遍历结果，最后一次性写入，降低IO开销。示例修改：

  Function loop_through_items_in_folder(ITM_path As Variant) As Variant
      Dim shell As Object, ITM As Object, Sub_ITM As Object
      Dim resultArr() As Variant, i As Integer
      Set shell = CreateObject("Shell.Application")
      Set ITM = shell.Namespace(ITM_path)
      ReDim resultArr(1 To ITM.items.Count, 1 To 2)
      i = 1
      For Each Sub_ITM In ITM.items
          resultArr(i, 1) = Sub_ITM.path
          resultArr(i, 2) = IIf(Sub_ITM.isfolder, "D", "F")
          i = i + 1
      Next Sub_ITM
      loop_through_items_in_folder = resultArr
  End Function
  

• 简化循环逻辑：主过程的Do Until循环可改为基于内存状态的遍历，避免反复更新LastRow。比如用集合存储待遍历目录，彻底脱离工作表状态依赖：

  Sub loop_through_files_in_subfolders()
      Dim wb As Workbook, ws As Worksheet
      Dim startPath As String, colPaths As New Collection
      Dim resultList As New Collection, itemInfo As Variant
      Dim shell As Object, ITM As Object, Sub_ITM As Object
      
      Set wb = ThisWorkbook
      Set ws = wb.Worksheets(1)
      startPath = "C:\Makro_test\F1.zip"
      colPaths.Add startPath
      
      Set shell = CreateObject("Shell.Application")
      
      Do While colPaths.Count > 0
          startPath = colPaths(1)
          colPaths.Remove 1
          
          Set ITM = shell.Namespace(startPath)
          For Each Sub_ITM In ITM.items
              itemInfo = Array(Sub_ITM.path, IIf(Sub_ITM.isfolder, "D", "F"))
              resultList.Add itemInfo
              If Sub_ITM.isfolder Then colPaths.Add Sub_ITM.path
          Next Sub_ITM
      Loop
      
      '批量写入工作表
      Dim resultArr() As Variant, i As Integer
      ReDim resultArr(1 To resultList.Count, 1 To 2)
      For i = 1 To resultList.Count
          resultArr(i, 1) = resultList(i)(0)
          resultArr(i, 2) = resultList(i)(1)
      Next i
      ws.Range("A2").Resize(UBound(resultArr, 1), 2).Value = resultArr
  End Sub
  

• 变量类型明确化：函数中wb、ws、shell等变量未声明具体类型，补充类型声明可提升代码稳定性与可读性，比如Dim shell As Object、Function loop_through_items_in_folder(ITM_path As Variant, wb As Workbook, ws As Worksheet)。

• 移除冗余标记操作：如果改用内存集合存储待遍历目录，就不需要再给工作表单元格标记颜色，进一步简化代码逻辑。

内容的提问来源于stack exchange，提问作者Piotrek Szostak