VBA代码优化求助：PDF转Excel数据提取流程优化

Sub Optimized_AN()
    ' -------------------------- 配置区域 --------------------------
    Const PDF_SOURCE_PATH As String = "\\rl.gov\data\userdata\H2138579\Tracking and trending program\pdf\AN\"
    Const TARGET_SHEET_NAME As String = "AN Farm"
    Const TEMP_WORD_PATH As String = "\\rl.gov\data\userdata\H2138579\Tracking and trending program\converted\AutoConvertedSurvey.docx"

    ' 搜索关键词与目标列映射：(搜索文本, 目标列)，格式变动时只需修改这里
    Dim searchMappings As Variant
    searchMappings = Array( _
        Array("D45", "AD"), _
        Array("D46", "AE"), _
        Array("D17", "AI"), _
        Array("D18", "AJ") _
    )
    ' -------------------------------------------------------------

    Dim excelSettings As Variant
    Dim fd As FileDialog
    Dim pdfPath As String
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim tempWs As Worksheet
    Dim targetWs As Worksheet
    Dim mapping As Variant
    Dim foundCell As Range
    Dim lastRow As Long
    
    ' 保存Excel原始设置并关闭不必要功能提速
    excelSettings = Array(Application.ScreenUpdating, Application.DisplayAlerts, Application.Calculation)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    
    On Error GoTo Cleanup ' 异常处理确保资源能释放
    
    ' 选择目标PDF文件
    Set fd = Application.FileDialog(msoFileDialogOpen)
    With fd
        .Title = "选择PDF报告"
        .InitialFileName = PDF_SOURCE_PATH
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "PDF文件", "*.pdf"
        If .Show <> -1 Then GoTo Cleanup ' 用户取消选择则退出
        pdfPath = .SelectedItems(1)
    End Set
    
    ' 创建Word实例并完成PDF转Word
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = False
    wordApp.DisplayAlerts = 0 ' 关闭Word提示
    
    ' 打开PDF自动转换，保存为临时Word文档
    Set wordDoc = wordApp.Documents.Open(pdfPath, ReadOnly:=True)
    wordDoc.SaveAs2 Filename:=TEMP_WORD_PATH, FileFormat:=16 ' wdFormatXMLDocument
    wordDoc.Close SaveChanges:=False
    
    ' 读取临时Word内容到Excel临时工作表
    Set wordDoc = wordApp.Documents.Open(TEMP_WORD_PATH, ReadOnly:=True)
    Set tempWs = ThisWorkbook.Worksheets.Add
    tempWs.Name = "TempData"
    
    ' 直接复制内容到Excel（避免无效交互）
    wordDoc.Content.Copy
    tempWs.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    
    ' 一次性取消所有合并单元格
    tempWs.Cells.UnMerge
    
    ' 清理无关数据区域
    tempWs.Range("A6:N37").ClearContents
    tempWs.Range("A300:N500").ClearContents
    
    ' 定位目标工作表
    Set targetWs = ThisWorkbook.Worksheets(TARGET_SHEET_NAME)
    
    ' 批量处理所有数据提取需求
    For Each mapping In searchMappings
        Set foundCell = tempWs.Cells.Find(What:=mapping(0), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)
        If Not foundCell Is Nothing Then
            lastRow = targetWs.Cells(targetWs.Rows.Count, mapping(1)).End(xlUp).Row + 1
            ' 直接赋值替代复制粘贴，提升效率
            targetWs.Cells(lastRow, mapping(1)).Value = foundCell.EntireRow.Cells(5).Value
        End If
    Next mapping
    
    ' 高效删除空列（从后往前遍历避免索引混乱）
    Dim col As Integer
    For col = tempWs.Cells.SpecialCells(xlLastCell).Column To 1 Step -1
        If WorksheetFunction.CountA(tempWs.Columns(col)) = 0 Then
            tempWs.Columns(col).Delete
        End If
    Next col

Cleanup:
    ' 清理临时资源
    If Not wordDoc Is Nothing Then wordDoc.Close SaveChanges:=False
    If Not wordApp Is Nothing Then wordApp.Quit
    Kill TEMP_WORD_PATH ' 自动删除临时Word文档（可选，如需保留可注释此行）
    If Not tempWs Is Nothing Then Application.DisplayAlerts = False: tempWs.Delete: Application.DisplayAlerts = True
    
    ' 恢复Excel原始设置
    Application.ScreenUpdating = excelSettings(0)
    Application.DisplayAlerts = excelSettings(1)
    Application.Calculation = excelSettings(2)
    
    ' 完成提示
    If Err.Number = 0 Then
        MsgBox "数据提取完成！", vbInformation
    Else
        MsgBox "处理出错：" & Err.Description, vbCritical
    End If
End Sub

优化核心说明 #

1. 集中可配置化

   • 所有可变参数（文件路径、搜索关键词、目标列）统一放在代码顶部，PDF格式变动时无需修改逻辑，仅需更新配置数组即可。
   • 用数组searchMappings管理所有数据提取规则，新增/修改数据点只需添加数组元素。

2. 效率提升

   • 仅创建1次Word实例，避免原代码重复启动Word的冗余耗时。
   • 彻底移除所有Select/Activate操作，直接引用对象操作，减少Excel界面交互开销。
   • 用直接赋值替代Copy/Paste，数据传输效率提升明显。
   • 优化空列删除逻辑，从后往前遍历避免列索引混乱。

3. 健壮性增强

   • 添加全局错误处理，确保异常时能正常关闭Word实例、清理临时文件，避免残留进程。
   • 对文件选择、查找结果添加空值判断，防止空引用崩溃。
   • 保存并恢复Excel原始设置，避免影响后续操作环境。

4. 代码简化

   • 合并PDF转Word与Excel导入步骤，减少中间环节。
   • 用循环批量处理所有数据提取需求，消除原代码中大量重复的查找-复制代码块。

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