如何用VBA实现Excel发票号匹配Word内容高亮并导出对应PDF

前置配置 #

• 打开存储Remitance文档的Word程序，按Alt+F11唤起VBA编辑器
• 点击顶部菜单「工具 > 引用」，勾选Microsoft Excel 16.0 Object Library（版本号随已安装的Office版本对应即可），确认后将Word文档保存为启用宏的docm格式
• 可根据自身文件存放路径修改代码开头的常量配置，默认配置要求Invoices.xlsx、存代码的Remitance.docm在同一文件夹，PDF会自动输出到同文件夹下的新建目录

完整代码 #

' 按需修改以下路径配置
Const EXCEL_INVOICE_PATH As String = "Invoices.xlsx" ' 发票列表Excel路径，默认同文件夹
Const PDF_OUTPUT_FOLDER As String = "Exported_Invoices\" ' PDF输出文件夹，默认同文件夹下新建
Const HIGHLIGHT_COLOR As WdColorIndex = wdYellow ' 匹配行高亮颜色

Sub BatchProcessInvoiceMatch()
    Dim xlApp As Excel.Application
    Dim xlWb As Excel.Workbook
    Dim xlWs As Excel.Worksheet
    Dim invoiceList As Variant
    Dim lastRow As Long, i As Long
    Dim findRng As Range
    Dim invoiceNo As String
    Dim matchCount As Long
    Dim currentPage As Long
    Dim pdfFileName As String
    Dim fso As Object
    
    ' 初始化文件系统对象，自动创建不存在的输出文件夹
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(ThisDocument.Path & "\" & PDF_OUTPUT_FOLDER) Then
        fso.CreateFolder ThisDocument.Path & "\" & PDF_OUTPUT_FOLDER
    End If
    
    ' 读取Excel内的发票号列表
    Set xlApp = New Excel.Application
    xlApp.Visible = False
    On Error Resume Next
    Set xlWb = xlApp.Workbooks.Open(ThisDocument.Path & "\" & EXCEL_INVOICE_PATH)
    If Err.Number <> 0 Then
        MsgBox "找不到发票列表Excel文件，请检查路径配置", vbExclamation
        xlApp.Quit
        Set xlApp = Nothing
        Exit Sub
    End If
    On Error GoTo 0
    Set xlWs = xlWb.Sheets(1) ' 默认读取Excel第一个工作表，可修改为指定表名
    lastRow = xlWs.Cells(xlWs.Rows.Count, "A").End(xlUp).Row ' 默认读取A列发票号，可修改列号
    ' 读取A1开始的所有非空发票号到数组
    invoiceList = xlWs.Range("A1:A" & lastRow).Value
    xlWb.Close SaveChanges:=False
    xlApp.Quit
    Set xlWs = Nothing: Set xlWb = Nothing: Set xlApp = Nothing
    
    ' 遍历所有发票号执行匹配
    ThisDocument.Activate
    Options.DefaultHighlightColorIndex = HIGHLIGHT_COLOR
    For i = 1 To UBound(invoiceList, 1)
        invoiceNo = Trim(CStr(invoiceList(i, 1)))
        If Len(invoiceNo) > 0 Then
            matchCount = 0
            Set findRng = ThisDocument.Content
            ' 全文循环检索匹配项，兼容同个发票号多次出现的场景
            With findRng.Find
                .ClearFormatting
                .Text = invoiceNo
                .Forward = True
                .Wrap = wdFindStop
                .MatchWholeWord = True ' 整词精确匹配，对齐VLOOKUP精确匹配逻辑
                .MatchCase = False ' 不区分大小写
                Do While .Execute
                    matchCount = matchCount + 1
                    ' 定位到匹配内容所在段落（行），设置高亮
                    findRng.Expand Unit:=wdParagraph
                    findRng.HighlightColorIndex = HIGHLIGHT_COLOR
                    ' 获取匹配项所在页码
                    currentPage = findRng.Information(wdActiveEndPageNumber)
                    ' 生成PDF文件名，重复匹配自动加序号避免重名报错
                    pdfFileName = ThisDocument.Path & "\" & PDF_OUTPUT_FOLDER & invoiceNo & IIf(matchCount > 1, "_" & matchCount, "") & ".pdf"
                    ' 导出当前页为PDF
                    ThisDocument.ExportAsFixedFormat _
                        OutputFileName:=pdfFileName, _
                        ExportFormat:=wdExportFormatPDF, _
                        Range:=wdExportFromTo, _
                        From:=currentPage, _
                        To:=currentPage
                    findRng.Collapse Direction:=wdCollapseEnd
                Loop
            End With
        End If
    Next i
    
    ' 释放对象
    Set findRng = Nothing
    Set fso = Nothing
    MsgBox "批量处理完成，共扫描" & UBound(invoiceList, 1) & "个发票号", vbInformation
End Sub

使用说明 #

• 代码默认读取Excel第一个工作表A列从A1开始的非空值作为发票号列表，如果发票号存放在其他列/其他工作表，修改代码中对应工作表、列号参数即可
• 如果需要使用绝对路径指定文件/输出文件夹位置，直接修改开头常量为完整路径（如D:\work\Invoices.xlsx），同时删除代码中路径拼接的ThisDocument.Path & "\"片段即可
• 同个发票号在Word文档中多次匹配时，导出的PDF会自动在文件名后追加_序号后缀，不会出现重名覆盖、运行中断的问题
• 所有匹配到的发票号所在段落都会按配置的高亮颜色标记，方便后续人工核对

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