求助修复Excel VBA PDF提取宏：运行卡顿无响应

卡顿无响应的核心原因 #

当前宏依赖Shell调用记事本+SendKeys操作的方式极不稳定：

• 固定等待时间（Application.Wait）无法适配不同文件大小和系统性能，容易导致窗口未就绪就执行后续操作
• SendKeys完全依赖窗口激活状态，一旦系统弹窗或焦点转移，就会触发错误或程序卡住
• 记事本打开大体积PDF时本身会卡顿，进一步拖慢整体流程

优化方案（基于免费版Adobe Acrobat） #

利用Adobe Acrobat的自动化接口直接提取PDF文本，替代记事本+剪贴板的不可靠流程，同时优化文本处理逻辑提升运行效率。

修改后的完整代码 #

Sub EXTRACT_DATA()
    Dim myPath As String
    Dim myfile As String
    Dim myExtension As String
    Dim ExR As Range
    Dim i As Long
    Dim x As Long
    Dim AllText As String
    Dim Paragraphs As Variant
    Dim Paragraph As Variant
    Dim CleanedParagraph As String
    Dim DatePart As String
    Dim ColB As String
    Dim ColC As String
    Dim ColD As String
    Dim ColE As String
    Dim FolderPicker As FileDialog
    Dim acroDoc As Object ' 延迟绑定Acrobat对象，无需手动引用库
    Dim numPages As Integer
    Dim pageNum As Integer

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual ' 关闭自动计算进一步提升速度
    
    On Error GoTo ResetSettings
    
    ' 选择文件夹
    Set FolderPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With FolderPicker
        .Title = "选择包含PDF文件的文件夹"
        .AllowMultiSelect = False
        If .Show <> -1 Then
            MsgBox "未选择文件夹，程序退出。", vbExclamation
            GoTo ResetSettings
        End If
        myPath = .SelectedItems(1) & "\"
    End With
    
    myExtension = "*.pdf"
    myfile = Dir(myPath & myExtension)
    
    If myfile = "" Then
        MsgBox "所选文件夹中未找到PDF文件，程序退出。", vbExclamation
        GoTo ResetSettings
    End If
    
    ' 初始化输出起始位置
    Set ExR = ThisWorkbook.Sheets("RAW").Range("A2")
    i = 0

    Do While myfile <> ""
        AllText = ""
        ' 初始化Acrobat文档对象
        Set acroDoc = CreateObject("AcroExch.PDDoc")
        
        ' 打开PDF文件
        If acroDoc.Open(myPath & myfile) Then
            numPages = acroDoc.GetNumPages()
            ' 提取每页文本
            For pageNum = 0 To numPages - 1
                AllText = AllText & acroDoc.GetPageText(pageNum) & vbNewLine
            Next pageNum
            acroDoc.Close
        Else
            MsgBox "无法打开文件: " & myfile, vbExclamation
            GoTo NextFile
        End If
        Set acroDoc = Nothing ' 释放对象
        
        If AllText = "" Then
            MsgBox "文件提取文本为空: " & myfile, vbExclamation
            GoTo NextFile
        End If
    
        ' 分割文本为行
        Paragraphs = Split(AllText, vbNewLine)
        x = 0
    
        For Each Paragraph In Paragraphs
            ' 跳过空行和包含排除关键词的行
            If Trim(Paragraph) = "" Or ContainsAny(CStr(Paragraph), Array("排除关键词1", "排除关键词2")) Then ' 替换为你的排除列表
                GoTo SkipLine
            End If
    
            ' 清理文本：去除括号、单引号及前后空格
            Paragraph = Trim(Replace(Replace(Replace(Paragraph, "(", ""), ")", ""), "'", ""))
            CleanedParagraph = Application.WorksheetFunction.Trim(Paragraph)
    
            ' 处理符合条件的行
            Dim lastSpace As Integer
            lastSpace = InStrRev(CleanedParagraph, " ")
            If lastSpace > 0 Then
                Dim lastWord As String
                lastWord = Trim(Right(CleanedParagraph, Len(CleanedParagraph) - lastSpace))
                
                If Len(lastWord) > 3 And IsDate(Left(CleanedParagraph, 8)) Then
                    DatePart = Left(CleanedParagraph, 8)
                    
                    ' 定位日期后的第一个非空格字符
                    Dim startIndex As Integer
                    startIndex = 9
                    While startIndex <= Len(CleanedParagraph) And Mid(CleanedParagraph, startIndex, 1) = " "
                        startIndex = startIndex + 1
                    Wend
                    
                    ' 提取各列数据
                    ColB = Mid(CleanedParagraph, startIndex, 12)
                    lastSpace = InStrRev(CleanedParagraph, " ")
                    ColE = Right(CleanedParagraph, Len(CleanedParagraph) - lastSpace)
                    
                    Dim firstSpaceAfterB As Integer
                    firstSpaceAfterB = InStr(startIndex + 12, CleanedParagraph, " ")
                    If firstSpaceAfterB > 0 Then
                        Dim nextSpaceAfterC As Integer
                        nextSpaceAfterC = InStr(firstSpaceAfterB + 1, CleanedParagraph, " ")
                        If nextSpaceAfterC > 0 Then
                            ColC = Mid(CleanedParagraph, firstSpaceAfterB + 1, nextSpaceAfterC - firstSpaceAfterB - 1)
                            
                            ' 提取ColD：直到第一个含数字的单词
                            Dim words() As String
                            Dim word As Variant
                            words = Split(Mid(CleanedParagraph, nextSpaceAfterC + 1, lastSpace - nextSpaceAfterC), " ")
                            ColD = ""
                            For Each word In words
                                If word Like "*[0-9]*" Then Exit For
                                ColD = ColD & word & " "
                            Next word
                            ColD = Trim(ColD)
                            
                            ' 写入Excel
                            ExR.Offset(x, 0).Value = DatePart
                            ExR.Offset(x, 1).Value = ColB
                            ExR.Offset(x, 2).Value = ColC
                            ExR.Offset(x, 3).Value = ColD
                            ExR.Offset(x, 4).Value = ColE
                            
                            x = x + 1
                        End If
                    End If
                End If
            End If
SkipLine:
        Next Paragraph
        
        i = i + x
        ' 刷新Excel避免缓存积压
        DoEvents
NextFile:
        myfile = Dir
    Loop

    ' 恢复设置
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "数据提取完成，共处理 " & i & " 行数据。", vbInformation
    
    Exit Sub

ResetSettings:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    If Not acroDoc Is Nothing Then
        acroDoc.Close
        Set acroDoc = Nothing
    End If
    MsgBox "发生错误: " & Err.Description, vbExclamation
End Sub

Function ContainsAny(text As String, substrings As Variant) As Boolean
    Dim i As Long
    For i = LBound(substrings) To UBound(substrings)
        If InStr(1, text, substrings(i), vbTextCompare) > 0 Then
            ContainsAny = True
            Exit Function
        End If
    Next i
    ContainsAny = False
End Function

关键优化点说明 #

1. 替换PDF提取方式：用Adobe Acrobat的AcroExch.PDDoc对象直接提取文本，完全避免外部窗口和SendKeys操作，稳定性大幅提升
2. 性能优化：关闭自动计算、减少不必要的变量重复声明，添加DoEvents释放系统资源
3. 错误处理增强：添加对象释放逻辑，避免Acrobat进程残留；完善空值和无效数据判断
4. 文本处理鲁棒性：优化日期后字符定位逻辑，避免因空格数量异常导致的错误

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