Excel VBA实现按序列号批量检索发票文件及信息需求

核心逻辑 #

• 遍历C:\Reports下月→日层级的文件夹，定位所有XML报告文件
• 读取每个XML文件中A列（发票号）与B列（序列号）的对应关系
• 匹配目标序列号，自动返回对应发票号并整理到当前工作表

VBA实现代码 #

Option Explicit

' 基础存储路径，可根据实际修改
Const BASE_PATH As String = "C:\Reports\"

Sub RetrieveInvoiceBySerial()
    Dim ws As Worksheet
    Dim serialRange As Range, cell As Range
    Dim fso As Object, rootFolder As Object, monthFolder As Object, dayFolder As Object
    Dim xmlFile As Object, xmlDoc As Object, rowNodes As Object, rowNode As Object
    Dim invoiceNum As String, serialNum As String
    Dim serialDict As Object
    
    ' 初始化字典存储序列号-发票号映射（忽略大小写匹配）
    Set serialDict = CreateObject("Scripting.Dictionary")
    serialDict.CompareMode = vbTextCompare
    
    ' 设置结果输出工作表
    Set ws = ActiveSheet
    ' 假设序列号在A列，从第2行开始到最后一行有数据的位置
    Set serialRange = ws.Range("A2:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
    
    ' 检查基础路径是否存在
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(BASE_PATH) Then
        MsgBox "基础路径不存在：" & BASE_PATH, vbCritical
        Exit Sub
    End If
    
    ' 遍历月→日文件夹层级
    Set rootFolder = fso.GetFolder(BASE_PATH)
    For Each monthFolder In rootFolder.SubFolders
        For Each dayFolder In monthFolder.SubFolders
            ' 遍历文件夹中的XML文件
            For Each xmlFile In dayFolder.Files
                If LCase(fso.GetExtensionName(xmlFile.Name)) = "xml" Then
                    ' 加载XML文档
                    Set xmlDoc = CreateObject("MSXML2.DOMDocument.6.0")
                    xmlDoc.async = False
                    xmlDoc.validateOnParse = False
                    If xmlDoc.Load(xmlFile.Path) Then
                        ' 获取所有行节点（需匹配你的XML实际结构，若节点名不是Row需修改）
                        Set rowNodes = xmlDoc.SelectNodes("//Row")
                        For Each rowNode In rowNodes
                            ' 读取A列（索引0）发票号、B列（索引1）序列号
                            invoiceNum = GetCellValue(rowNode, 0)
                            serialNum = GetCellValue(rowNode, 1)
                            ' 非空时存入字典，重复序列号保留最新发票号
                            If invoiceNum <> "" And serialNum <> "" Then
                                serialDict(serialNum) = invoiceNum
                            End If
                        Next rowNode
                    Else
                        Debug.Print "加载XML失败：" & xmlFile.Path & "，错误：" & xmlDoc.parseError.reason
                    End If
                End If
            Next xmlFile
        Next dayFolder
    Next monthFolder
    
    ' 匹配序列号并填充发票号
    For Each cell In serialRange
        cell.Offset(0, 1).Value = IIf(serialDict.Exists(cell.Value), serialDict(cell.Value), "未找到")
    Next cell
    
    MsgBox "检索完成！", vbInformation
    
    ' 释放对象
    Set serialDict = Nothing
    Set fso = Nothing
    Set xmlDoc = Nothing
End Sub

' 辅助函数：从行节点中获取指定索引单元格的值
Private Function GetCellValue(rowNode As Object, cellIndex As Integer) As String
    Dim cellNodes As Object
    Set cellNodes = rowNode.SelectNodes("Cell")
    If cellNodes.Length > cellIndex Then
        GetCellValue = cellNodes(cellIndex).SelectSingleNode("Data").Text
    Else
        GetCellValue = ""
    End If
End Function

使用步骤 #

1. 打开需要处理的Excel文件，按Alt + F11打开VBA编辑器
2. 插入新模块（右键工程→插入→模块），粘贴上述代码
3. 在当前工作表A列输入需要核查的序列号（第1行可设“序列号”为表头）
4. 返回Excel界面，按Alt + F8，选择RetrieveInvoiceBySerial宏运行

注意事项 #

• 若你的XML报告结构与代码中节点名（如<Row>、<Cell>）不匹配，需修改代码中SelectNodes的参数，匹配实际XML节点
• 代码依赖Scripting.Dictionary和MSXML2.DOMDocument.6.0组件，Office默认环境已包含
• 处理大量XML文件时，建议关闭其他占用资源的程序，避免卡顿

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