求助：如何从转成Word的PDF发票中提取指定信息至Excel

核心思路 #

• 借助Word的Find对象精准定位目标关键词（"Delivery Address"和"Contact Person"）
• 从关键词位置向后提取对应State和联系人姓名，避免全文档复制的冗余操作
• 直接将提取结果写入Excel，解决大文件粘贴失败的问题

修改后的代码 #

Sub ExtractSpecificDataFromPDF()
    Dim s As String
    Dim targetRow As Excel.Range
    Dim wdApp As New Word.Application
    Dim wdDoc As Word.Document
    Dim wdRange As Word.Range
    Dim stateText As String
    Dim contactName As String
    
    ' 替换为你的PDF文件路径
    s = "\\my path\my file.pdf"
    
    ' 打开PDF并自动转换为Word文档
    Set wdDoc = wdApp.Documents.Open(Filename:=s, Format:="PDF Files", ConfirmConversions:=False)
    Set wdRange = wdDoc.Content
    
    ' 提取Delivery Address中的State
    With wdRange.Find
        .ClearFormatting
        .Text = "Delivery Address"
        .MatchCase = False
        .Wrap = wdFindContinue
        If .Execute Then
            wdRange.Collapse Direction:=wdCollapseEnd
            ' 提取关键词后到换行前的内容，可根据实际格式调整终止符
            wdRange.MoveEndUntil Cset:=vbCrLf, Count:=wdForward
            ' 示例：假设格式为"..., State: CA"，通过冒号分割提取State
            stateText = Trim(Split(Trim(wdRange.Text), ":")(1))
        Else
            stateText = "未找到Delivery Address"
        End If
    End With
    
    ' 提取Contact Person中的姓名
    Set wdRange = wdDoc.Content ' 重置Range到文档开头
    With wdRange.Find
        .ClearFormatting
        .Text = "Contact Person"
        .MatchCase = False
        .Wrap = wdFindContinue
        If .Execute Then
            wdRange.Collapse Direction:=wdCollapseEnd
            wdRange.MoveEndUntil Cset:=vbCrLf, Count:=wdForward
            ' 示例：假设格式为"Contact Person: John Doe"，通过冒号分割提取姓名
            contactName = Trim(Split(Trim(wdRange.Text), ":")(1))
        Else
            contactName = "未找到Contact Person"
        End If
    End With
    
    ' 将结果写入Excel（State在A列，姓名在B列）
    Set targetRow = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    targetRow.Value = stateText
    targetRow.Offset(0, 1).Value = contactName
    
    ' 清理资源
    wdDoc.Close SaveChanges:=False
    wdApp.Quit
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Set targetRow = Nothing
    Set wdRange = Nothing
End Sub

关键调整说明 #

• 格式适配：代码中的提取逻辑（如Split分隔符、MoveEndUntil终止符）需要根据你的发票实际排版修改。如果State是单独一行，可改为wdRange.MoveDown Unit:=wdLine, Count:=1后提取整行内容。
• 引用设置：确保Excel VBA编辑器中已勾选Microsoft Word xx.x Object Library（路径：工具→引用）。
• 异常处理：可按需添加错误捕获代码，处理文件打开失败、关键词未找到等情况。

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