VBA从pdf复制数据

我有大量的PDF文件，我想将文件中的所有数据复制到电子表格中的一列。

这是我一直的代码。 它所做的只是打开pdf，使用control-a，然后使用control-c来复制，然后激活工作簿，find一个打开的列，并用control-v Sendkey粘贴数据。 它工作正常，但它只粘贴从最后一个文件的最后数据（我有一个范围与path名打开，并从所有复制数据，但实际上只是粘贴最后一个）。

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 

Answer 1

Jeanno的权利，如果你有Acrobat，那么直接使用它的API库来处理文件比变通办法好得多。 我每天使用这个将pdf文件转换成数据库条目。

你的代码有一些问题，但我怀疑最大的问题是使用SendKeys "^v"来粘贴到Excel中。 你最好select你想要的单元格，然后使用Selection.Paste 。 或者更好的办法是将剪贴板中的内容转移到一个variables中，然后在写入到电子表格之前根据需要将其parsing出来 – 但是这会增加一些复杂性，在这种情况下并没有多大帮助。

要使用下面的代码，请确保在“工具”>“参考”下select“Acrobat xxtypes库”。

 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") ，应该一步完成全选和复制的select，但是我遇到了问题，所以我坚持上面的两步法。

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

Answer 2

我不能完全让你的代码工作，但我的猜测是，它是复制所有的数据，但每次通过循环覆盖它。 为了解决这个问题：

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

而不是两行开始activesheet.range（“A1”）。Select and Selection.End ….

Answer 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 

Answer 4

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

现在为什么我复制数据从PDF到单词，然后从单词复制和粘贴到Excel，因为我想要的数据从PDF格式的确切格式到我的Excel表单，如果我直接从PDF复制到Excel它会粘贴整个数据从PDF到单个单元格意味着即使我有两列或多行它将粘贴我所有的数据到一列，也在单个单元格，但如果我复制从单词到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 

Answer 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