批量PDF转XLSX的VBA代码问题：粘贴内容显示为图片

你的问题核心是依赖Word的PDF转译能力存在局限性——当PDF包含扫描件、复杂格式或Word无法识别为文本的内容时，粘贴操作会默认保留图片格式；再加上原代码的PasteSpecial未指定参数，进一步放大了这个问题。下面给两种无需用户手动用Power Query的解决思路：

思路1：改进原Word中转逻辑（快速修复） #

修改粘贴方式强制转为可编辑文本/数值，同时修正原代码里的语法错误（变量大小写、字符串闭合、对象调用错误）：

Sub PDF_To_Excel_Word_Improved()
    Dim setting_sh As Worksheet
    Set setting_sh = ThisWorkbook.Sheets("PDF Export")
    
    Dim pdf_path As String, excel_path As String
    pdf_path = setting_sh.Range("B3").Value
    excel_path = setting_sh.Range("C3").Value
    
    ' 确保输出路径存在，避免保存失败
    Dim fso As New FileSystemObject
    If Not fso.FolderExists(excel_path) Then fso.CreateFolder excel_path
    
    Dim fo As Folder, f As File
    Set fo = fso.GetFolder(pdf_path)
    
    Dim wa As Object, doc As Object, wr As Object
    Set wa = CreateObject("word.application")
    wa.Visible = False ' 后台运行，避免干扰用户操作
    
    Dim nwb As Workbook, nsh As Worksheet
    
    For Each f In fo.Files
        ' 只处理PDF格式文件
        If LCase(fso.GetExtensionName(f.Path)) = "pdf" Then
            Set doc = wa.Documents.Open(f.Path, False, Format:="PDF Files")
            Set wr = doc.Content ' 直接获取整个文档内容，替代原代码的冗余写法
            
            Set nwb = Workbooks.Add
            Set nsh = nwb.Sheets(1)
            
            wr.Copy
            ' 强制粘贴为数值+格式，彻底避免图片格式
            nsh.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            
            ' 修正字符串闭合错误，指定文件格式
            nwb.SaveAs Filename:=excel_path & "\" & Replace(f.Name, ".pdf", ".xlsx"), FileFormat:=xlOpenXMLWorkbook
            nwb.Close SaveChanges:=False
            doc.Close SaveChanges:=False
        End If
    Next f
    
    wa.Quit
    MsgBox "批量转换完成！"
End Sub

思路2：用Adobe Acrobat原生API（更可靠，推荐） #

既然你已安装最新版Acrobat，直接用它的VBA接口解析PDF，比Word中转的识别精度高得多，毕竟是PDF格式的原生处理工具：

前置操作 #

在VBA编辑器的工具→引用中，勾选对应版本的Adobe Acrobat xx.x Type Library（xx.x为你的Acrobat版本号）。

代码实现 #

Sub PDF_To_Excel_Acrobat()
    Dim setting_sh As Worksheet
    Set setting_sh = ThisWorkbook.Sheets("PDF Export")
    
    Dim pdf_path As String, excel_path As String
    pdf_path = setting_sh.Range("B3").Value
    excel_path = setting_sh.Range("C3").Value
    
    Dim fso As New FileSystemObject
    If Not fso.FolderExists(excel_path) Then fso.CreateFolder excel_path
    
    Dim fo As Folder, f As File
    Set fo = fso.GetFolder(pdf_path)
    
    Dim acroApp As Acrobat.CAcroApp, acroDoc As Acrobat.CAcroPDDoc
    Dim acroPage As Acrobat.CAcroPDPage, pageText As String
    Dim nwb As Workbook, nsh As Worksheet, rowNum As Long
    
    Set acroApp = CreateObject("AcroExch.App")
    Set acroDoc = CreateObject("AcroExch.PDDoc")
    
    For Each f In fo.Files
        If LCase(fso.GetExtensionName(f.Path)) = "pdf" Then
            If acroDoc.Open(f.Path) Then
                Set nwb = Workbooks.Add
                Set nsh = nwb.Sheets(1)
                rowNum = 1
                
                ' 遍历PDF所有页面提取文本
                For i = 0 To acroDoc.GetNumPages - 1
                    Set acroPage = acroDoc.AcquirePage(i)
                    pageText = ExtractPageText(acroPage)
                    
                    ' 将文本按换行拆分到单元格
                    Dim textLines As Variant
                    textLines = Split(pageText, vbCrLf)
                    
                    For Each line In textLines
                        If Trim(line) <> "" Then
                            nsh.Cells(rowNum, 1).Value = line
                            rowNum = rowNum + 1
                        End If
                    Next line
                Next i
                
                nwb.SaveAs Filename:=excel_path & "\" & Replace(f.Name, ".pdf", ".xlsx"), FileFormat:=xlOpenXMLWorkbook
                nwb.Close SaveChanges:=False
                acroDoc.Close
            End If
        End If
    Next f
    
    acroApp.Exit
    Set acroDoc = Nothing
    Set acroApp = Nothing
    MsgBox "批量转换完成！"
End Sub

' 辅助函数：提取单页PDF文本
Function ExtractPageText(page As Acrobat.CAcroPDPage) As String
    Dim pdTextSelect As Acrobat.CAcroPDTextSelect
    Dim textRange As Acrobat.CAcroTextRange
    Dim fullText As String, i As Integer
    
    Set pdTextSelect = page.CreateTextSelect(0, 0, page.GetMediaBox.Width, page.GetMediaBox.Height)
    fullText = ""
    
    For i = 0 To pdTextSelect.GetNumTextRanges - 1
        Set textRange = pdTextSelect.GetTextRange(i)
        fullText = fullText & textRange.Text
    Next i
    
    ExtractPageText = fullText
End Function

注意事项 #

• 若PDF是纯扫描件（无文本层），两种思路都无法提取可编辑文本，需使用Acrobat Pro的OCR功能，可在代码中调用Acrobat的OCR接口实现自动识别（需Acrobat Pro版本）。

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