从多个pdf文件复制数据答案

【问题标题】：Copying data from multiple pdf files从多个pdf文件复制数据
【发布时间】：2015-05-04 07:15:44
【问题描述】：

我有 pdf 文件，我想将其中的所有数据复制到电子表格的列中。

这是我的代码。它所做的只是打开 pdf，使用 control-a，然后 control-c 进行复制，然后激活工作簿，找到一个打开的列并使用 control-v Sendkey 粘贴数据。

我有一个带有路径名的范围，它打开并复制所有数据，但只粘贴最后一个。

Sub StartAdobe1()

Dim AdobeApp As String
Dim AdobeFile As String
Dim StartAdobe
Dim fname As Variant
Dim iRow As Integer
Dim Filename As String

For Each fname In Range("path")

    AdobeApp = "C:\Program Files (x86)\Adobe\Reader 10.0\Reader\AcroRd32.exe"
    StartAdobe = Shell("" & AdobeApp & " " & fname & "", 1)

    Application.Wait Now + TimeValue("00:00:01")
    SendKeys "^a", True
    Application.Wait Now + TimeValue("00:00:01")
    SendKeys "^c"
    Application.Wait Now + TimeValue("00:00:01")
    SendKeys ("%{F4}")
    Windows("transfer (Autosaved).xlsm").Activate
    Worksheets("new").Activate

    ActiveSheet.Range("A1").Select
    Selection.End(xlToRight).Offset(0, 1).Select

    SendKeys "^v"
    Application.Wait Now + TimeValue("00:00:2")

Next fname

【问题讨论】：

您的计算机上是否安装了 Acrobat（不是 Reader）。如果是这样，您可以使用 Acrobat 对象模型将数据从 PDF 复制到 Excel，而无需使用 SendKeys。如果你这样做，请告诉我，我会用示例代码发布答案
是的，我也有杂技演员

标签： excel vba pdf

【解决方案1】：

我无法让您的代码正常工作，但我猜它正在复制所有数据，但每次循环都会覆盖它。要解决此问题，请尝试：

ActiveSheet.Cells(1, ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1).Select

而不是从 activesheet.range("A1").Select 和 Selection.End.... 开始的两行。

【讨论】：

谢谢。它只是给了我同样的结果。我给你举个例子。现在我只有2个文件路径的范围（为了简单起见，我解决了错误）。它打开第一个pdf，我可以看到它复制了所有数据（control-a），然后电子表格被激活并选择了正确的单元格。但是它不会粘贴它只是继续打开下一个 pdf，其中所有数据都被选中，电子表格再次激活并再次选择单元格，但这一次它确实粘贴了数据。
可能值得尝试更多文件，看看它是否只复制第二个、最后一个、跳过第一个或其他文件组合。

【解决方案2】：

Jeanno 说得对，如果您有 Acrobat，那么使用它的 API 库直接处理文件比使用变通方法要好得多。我每天都使用它来将 pdf 文件转换为数据库条目。

您的代码有一些问题，但我怀疑最大的问题是使用SendKeys "^v" 粘贴到 Excel 中。你最好选择你想要的单元格然后使用Selection.Paste。或者更好的是，将剪贴板的内容传输到一个变量，然后在写入电子表格之前在后端根据需要解析它——但这会增加一堆复杂性，在这种情况下对你没有多大帮助。

要使用下面的代码，请务必在“工具”>“参考”下选择“Acrobat x.x 类型库”。

Sub StartAdobe1()
    Dim fName       As Variant
    Dim wbTransfer  As Excel.Workbook
    Dim wsNew       As Excel.Worksheet
    Dim dOpenCol    As Double
    Dim oPDFApp     As AcroApp
    Dim oAVDoc      As AcroAVDoc
    Dim oPDDoc      As AcroPDDoc

    'Define your spreadsheet
    Set wbTransfer = Workbooks("transfer (Autosaved).xlsm")
    Set wsNew = wbTransfer.Sheets("new")
    'Find first open column
    dOpenCol = ws.Cells(1, columns.count).End(xlToleft).Column + 1

    'Instantiate Acrobat Objects
    Set oPDFApp = CreateObject("AcroExch.App")
    Set oAVDoc = CreateObject("AcroExch.AVDoc")
    Set oPDDoc = CreateObject("AcroExch.PDDoc")

For Each fName In Range("path")

    'Open the PDF file. The AcroAVDoc.Open function returns a true/false 
    'to tell you if it worked
    If oAVDoc.Open(fName.Text, "") = True Then
        Set oPDDoc = oAVDoc.GetPDDoc
    Else
        Debug.Assert False
    End If

    'Copy all using Acrobat menu
    oPDFApp.MenuItemExecute ("SelectAll")
    oPDFApp.MenuItemExecute ("Copy")

    'Paste into open column
    wbTransfer.Activate
    wsNew.Cells(1, dOpenCol).Select
    ActiveSheet.Paste

    'Select next open column
    dOpenCol = dOpenCol + 1

    oAVDoc.Close (1)    '(1)=Do not save changes
    oPDDoc.Close

Next

    'Clean up
    Set wbTransfer = Nothing
    Set wsNew = Nothing
    Set oPDFApp = Nothing
    Set oAVDoc = Nothing
    Set oPDDoc = Nothing


End Sub

注意： 1-还有一个菜单项oPDFApp.MenuItemExecute ("CopyFileToClipboard")应该一步完成全选并复制，但我遇到了问题，所以我坚持上面的两步方法。

2-一个 pdf 文件由两个对象组成，oAVDoc 和 oPDDoc。文件的不同方面由每个方面控制。在这种情况下，您可能只需要oAVDoc。尝试注释掉处理oPDDoc 的行，看看没有它们是否可以工作。

【讨论】：

我知道这很旧，但是您的“查找第一个打开的列”引用 ws 不是 wsNew :)

【解决方案3】：

试试这个代码，这可能会起作用：

 Sub Shell_Copy_Paste()

   Dim o As Variant
   Dim wkSheet As Worksheet

   Set wkSheet = ActiveSheet

   o = Shell("C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe C:\Users\saurabh.ad.sharma\Desktop\red.pdf", vbNormalFocus)

   Application.Wait (Now + TimeSerial(0, 0, 2)) 'Wait for Acrobat to load

   SendKeys "^a"   'Select All
   SendKeys "^c"   'Copy
   SendKeys "%{F4}"    'Close shell application

   wkSheet.Range("B5").Select
   SendKeys "^v"   'Paste

End Sub

【讨论】：

【解决方案4】：

下面的代码将从 PDF 中复制数据并将其粘贴到 WORD 中，然后从 WORD 中复制数据，然后将其粘贴到 EXCEL 中。

现在为什么我要将数据从 pdf 复制到 word，然后从 word 复制并将其粘贴到 excel，因为如果我直接从 pdf 复制到 excel，我希望将 pdf 中的数据以精确的格式复制到我的 excel 表中，它将粘贴将pdf中的全部数据放入单个单元格意味着即使我有两列或多行，它也会将我的所有数据粘贴到一列中，并且也粘贴到单个单元格中，但是如果我从word复制到excel，它将保留其原始格式并且两列将仅在 Excel 中粘贴为两列。

Private Sub CommandButton3_Click()  '(load pdf)


   Dim o As Variant
Set appWord = CreateObject("Word.Application")
 o = Shell("C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe C:\Users\saurabh.ad.sharma\Desktop\Book1.pdf", vbNormalFocus)   'loading adobe reader & pdf file from their location
 Application.Wait (Now + TimeSerial(0, 0, 2))
   SendKeys ("^a")
SendKeys ("^c")
 SendKeys "%{F4}"
Application.Wait Now + TimeValue("00:00:01")
 Set appWord = CreateObject("Word.Application")
 appWord.Visible = True
 appWord.Documents.Add.Content.Paste
With appWord

       .ActiveDocument.SaveAs Filename:=ThisWorkbook.Path & "\pdf" & ".docx", FileFormat:=wdocument   'saving word file in docx format
        .ActiveWindow.Close
        .Quit
    End With

MsgBox " pdf is loaded "
MsgBox " Paste to EXCEL "

    Set appWord = CreateObject("Word.Application")
     appWord.Visible = True

  appWord.Documents.Open "C:\Users\saurabh.ad.sharma\Desktop\pdf.docx" 'opening word document
      appWord.Selection.WholeStory
      appWord.Selection.Copy
   Set wkSheet = ActiveSheet
    wkSheet.Range("A1").Select
    wkSheet.Paste 'pasting to the excel file

End Sub

【讨论】：

【解决方案5】：

这是我上面代码的更多修改版本，它不会保存任何文档，它会将数据保存在剪贴板中，并且会快速执行..

Private Sub CommandButton3_Click()  '(load pdf)


   Dim o As Variant
Set appWord = CreateObject("Word.Application")
 o = Shell("C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe C:\Users\saurabh.ad.sharma\Desktop\Book1.pdf2", vbNormalFocus)
 Application.Wait (Now + TimeSerial(0, 0, 2))
   SendKeys ("^a")
SendKeys ("^c")
 SendKeys "%{F4}"
Application.Wait Now + TimeValue("00:00:01")
 Set appWord = CreateObject("Word.Application")
 appWord.Visible = False
 appWord.Documents.Add.Content.Paste
With appWord

       .Selection.WholeStory
       .Selection.Copy
       .ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
       .Quit
End With

MsgBox " pdf is loaded "
MsgBox " Paste to EXCEL "


   Set wkSheet = ActiveSheet
    wkSheet.Range("A1").Select
    wkSheet.Paste

End Sub

【讨论】：

【解决方案6】：

我有类似的问题。如前所述，最好的解决方案是使用 Adobe API。就我而言，这是不可能的，因为宏是为 100 多位 PC 上没有 Adobe Pro 的用户设计的。

我最近开发的终极解决方案是在 C# 中转换构建（免费使用 Visual Studio 和 iText 库），将其安装在最终用户的计算机上，并在需要时通过 VBA 运行。以下是一些链接以获得更多指导：

如何用C#开发pdf转换器：link
如何在 C# 中创建 Excel 插件：link
如何从 VBA 运行 C# 插件：link

总体而言，它相当复杂，但一旦完成就像做梦一样。

前面提到的另一个解决方案是在 VBA 中使用 sendkeys。我的经验是，它需要一些优化来处理各种打开和复制时间（取决于文件大小）。下面是对我有用的代码，但它甚至不如 C# 转换器那么快速和稳定。

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'Initialize sleep function via Windows API
Public Sub CopyToSheet(destinationSheet As Worksheet, pathToPdf as String)
'Copy data from PDF to worksheet

    'Initialize timer
    Dim StartTime As Double
    StartTime = Timer

    'Clear clipboard
    Dim myData As DataObject
    Set myData = New DataObject
    myData.SetText text:=Empty
    myData.PutInClipboard
    Set myData = Nothing

    'Build file paths
    Dim pathToAdobe As String
    pathToAdobe = """C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"""
    pathToPdf = """" & pathToPdf & """"

    'Open PDF and wait untill it is open. If file is already opened it will be just activated
    Dim pdfId As Long
    pdfId = Shell(pathToAdobe & " " & pathToPdf, vbMaximizedFocus)
    Do
        Sleep (500)
        If Round(Timer - StartTime, 2) > 9 Then MsgBox "Failed to open PDF": Exit Sub  'Safety check
    Loop Until Me.IsPdfOpen(pathToPdf)

    'Copy and wait until copying is completed
    SendKeys "^a"
    SendKeys "^c"
    Do
        Sleep (500)
        If Round(Timer - StartTime, 2) > 18 Then MsgBox "Failed to copy data to clipboard": Exit Sub  'Safety check
    Loop Until Me.GetClipboardStatus = "ClipboardHasData"

    'Paste data into worksheet
    destinationSheet.Activate
    destinationSheet.Range("A1").Select
    destinationSheet.Paste

    'Close pdf
    Call Shell("TaskKill /F /PID " & CStr(pdfId), vbHide)

    'Clear clipboard
    Set myData = New DataObject
    myData.SetText text:=Empty
    myData.PutInClipboard
    Set myData = Nothing

End Sub

Function IsPdfOpen(pathToPdf) As Boolean
'Check if PDF is already opened

    'Build window name (window name is name of the application on Windows task bar)
    Dim windowName As String
    windowName = pathToPdf
    windowName = Mid(windowName, InStrRev(windowName, "\") + 1, Len(windowName) - InStrRev(windowName, "\") + 1)
    windowName = windowName + " - Adobe Acrobat Reader DC"

    'Try to activate application to check if is opened
    On Error Resume Next
    AppActivate windowName, True
    Select Case Err.Number
        Case 5: IsPdfOpen = False
        Case 0: IsPdfOpen = True
        Case Else: Debug.Assert False
    End Select
    On Error GoTo 0

End Function

Function GetClipboardStatus() As String
'Check if copying data to clipboard is completed

    Dim tempString As String
    Dim myData As DataObject

    'Try to put data from clipboard to string to check if operations on clipboard are completed
    On Error Resume Next
    Set myData = New DataObject
    myData.GetFromClipboard
    tempString = myData.GetText(1)
    If Err.Number = 0 Then
        If tempString = "" Then
            GetClipboardStatus = "ClipboardEmpty"
        Else
            GetClipboardStatus = "ClipboardHasData"
        End If
    Else
        GetClipboardStatus = "ClipboardBusy"
    End If
    On Error GoTo 0

    Set myData = Nothing

End Function

【讨论】：