实现遍历父文件夹及子文件夹统计XML中<Headline>标签数量

原代码仅支持单个文件夹的XML文件统计，要实现遍历父文件夹下所有子文件夹，只需添加递归遍历子文件夹的逻辑即可，修改后的完整代码如下：

Option Explicit

Sub process_all_folders()
    Dim iRow As Long, wb As Workbook, ws As Worksheet
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(1)
    ws.UsedRange.Clear
    ws.Range("A1:C1") = Array("文件路径", "第一个<Headline>内容", "<Headline>标签计数")
    iRow = 1
    
    ' 初始化FSO和正则表达式
    Dim FSO As Object, regEx As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set regEx = CreateObject("VBScript.RegExp")
    With regEx
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = "<Headline>(.*)</Headline>"
    End With
    
    ' 选择父文件夹
    Dim parentFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "请选择父文件夹"
        .Show
        .AllowMultiSelect = False
        If .SelectedItems.Count = 0 Then
            MsgBox "未选择任何文件夹"
            Exit Sub
        End If
        parentFolder = .SelectedItems(1)
    End With
    
    Application.ScreenUpdating = False
    ' 调用递归函数遍历所有子文件夹
    Call TraverseFolder(FSO.GetFolder(parentFolder), regEx, ws, iRow)
    ws.UsedRange.Columns.AutoFit
    Application.ScreenUpdating = True
    MsgBox "统计完成"
End Sub

' 递归遍历文件夹的函数
Sub TraverseFolder(currentFolder As Object, regEx As Object, ws As Worksheet, ByRef iRow As Long)
    Dim xmlFile As Object, subFolder As Object
    Dim txt As String, ts As Object, m As Object
    
    ' 处理当前文件夹下的所有XML文件
    For Each xmlFile In currentFolder.Files
        If LCase(Right(xmlFile.Name, 4)) = ".xml" Then
            iRow = iRow + 1
            ' 写入完整文件路径，方便定位文件
            ws.Cells(iRow, 1) = xmlFile.Path
            
            ' 读取文件内容
            Set ts = xmlFile.OpenAsTextStream
            txt = ts.ReadAll
            ts.Close
            
            ' 匹配并统计标签
            If regEx.Test(txt) Then
                Set m = regEx.Execute(txt)
                ws.Cells(iRow, 2) = m(0).SubMatches(0)
                ws.Cells(iRow, 3) = m.Count
            Else
                ws.Cells(iRow, 2) = "无匹配标签"
                ws.Cells(iRow, 3) = 0
            End If
        End If
    Next xmlFile
    
    ' 递归处理子文件夹
    For Each subFolder In currentFolder.SubFolders
        Call TraverseFolder(subFolder, regEx, ws, iRow)
    Next subFolder
End Sub

关键改动说明： #

• 新增TraverseFolder递归函数，实现对当前文件夹及其所有子文件夹的深度遍历
• 将文件读取、标签匹配统计的核心逻辑迁移到递归函数中，复用代码逻辑
• 第一列改为写入完整文件路径，解决子文件夹中重名文件无法区分的问题
• 优化表头文字，明确各列数据含义
• 统计完成后添加提示弹窗，反馈操作状态

内容的提问来源于stack exchange，提问作者Salman Shafi