VBA – 从PDF中提取数据并添加到工作表
我有一个项目，我试图从PDF文档中提取数据到工作表中。 PDF已经显示和文本，可以手动复制并粘贴到Excel文档。
我目前正在通过SendKeys来完成这个项目，而且当我尝试从我的PDF文档中粘贴数据时，我得到的错误实际上并没有太好的效果！ 有没有人知道更漂亮的做事方式？ 这将是一个很大的帮助！ 而且，为什么我的粘贴不工作？！ 如果我粘贴后，macros停止运行它正常粘贴？ 代码如下：
Dim myPath As String, myExt As String Dim ws As Worksheet Dim openPDF As Object 'Dim pasteData As MSForms.DataObject Dim fCell As Range 'Set pasteData = New MSForms.DataObject Set ws = Sheets("DATA") If ws.Cells(ws.Rows.Count, "A").End(xlUp).Row > 1 Then Range("A3:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row).ClearContents myExt = "\*.pdf" 'When Scan Receipts Button Pressed Scan the selected folder/s for receipts For Each fCell In Range(ws.Cells(1, 1), ws.Cells(1, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column)) myPath = Dir(fCell.Value & myExt) Do While myPath <> "" myPath = fCell.Value & "\" & myPath Set openPDF = CreateObject("Shell.Application") openPDF.Open (myPath) Application.Wait Now + TimeValue("00:00:2") SendKeys "^a" Application.Wait Now + TimeValue("00:00:2") SendKeys "^c" 'Application.Wait Now + TimeValue("00:00:2") ws.Select ActiveSheet.Paste 'pasteData.GetFromClipboard 'ws.Cells(3, 1) = pasteData.GetText Exit Sub myPath = Dir Loop Next fCell 您可以打开PDF文件并使用Adobe库（我相信您可以从Adobe下载，作为SDK的一部分，但它也随Acrobat一起提供）
请确保将库添加到您的参考（在我的机器上它是Adobe Acrobat 10.0types库，但不知道这是否是最新版本）
即使使用Adobe库也不是微不足道的（您需要添加自己的错误陷阱等）：
Function getTextFromPDF(ByVal strFilename As String) As String Dim objAVDoc As New AcroAVDoc Dim objPDDoc As New AcroPDDoc Dim objPage As AcroPDPage Dim objSelection As AcroPDTextSelect Dim objHighlight As AcroHiliteList Dim pageNum As Long Dim strText As String strText = "" If (objAvDoc.Open(strFilename, "") Then Set objPDDoc = objAVDoc.GetPDDoc For pageNum = 0 To objPDDoc.GetNumPages() - 1 Set objPage = objPDDoc.AcquirePage(pageNum) Set objHighlight = New AcroHiliteList objHighlight.Add 0, 10000 ' Adjust this up if it's not getting all the text on the page Set objSelection = objPage.CreatePageHilite(objHighlight) If Not objSelection Is Nothing Then For tCount = 0 To objSelection.GetNumText - 1 strText = strText & objSelection.GetText(tCount) Next tCount End If Next pageNum objAVDoc.Close 1 End If getTextFromPDF = strText End Function
这样做基本上与你正在做的是一样的 – 只使用Adobe自己的库。 它一次通过PDF一页，高亮显示页面上的所有文本，然后将它（一次一个文本元素）放到一个string中。
请记住，从中得到的东西可能会充满各种非打印字符（换行符，换行符等），甚至最终会出现在连续的文本块中，因此您可能需要额外的代码清理它之前，你可以使用它。
希望有所帮助！
随着时间的推移，我发现以结构化格式从PDF中提取文本是一件难事。 但是，如果你正在寻找一个简单的解决scheme，你可能要考虑XPDF工具pdftotext 。
提取文本的伪代码将包括：
- 使用
SHELLVBA语句从PDF中将文本提取到使用XPDF的临时文件 - 使用顺序文件读取语句将临时文件内容读取到string中
- 将string粘贴到Excel中
下面的简单例子：
Sub ReadIntoExcel(PDFName As String) 'Convert PDF to text Shell "C:\Utils\pdftotext.exe -layout " & PDFName & " tempfile.txt" 'Read in the text file and write to Excel Dim TextLine as String Dim RowNumber as Integer Dim F1 as Integer RowNumber = 1 F1 = Freefile() Open "tempfile.txt" for Input as #F1 While Not EOF(#F1) Line Input #F1, TextLine ThisWorkbook.WorkSheets(1).Cells(RowNumber, 1).Value = TextLine RowNumber = RowNumber + 1 Wend Close #F1 End Sub
通过用户交互仿真进行复制和粘贴可能不可靠（例如，popup窗口出现并切换焦点）。 您可能有兴趣尝试商业ByteScout PDF Extractor SDK ，它是专门为从PDF中提取数据而devise的，它可以在VBA中使用。 它也能够使用VB代码以CSV的forms从发票和表格中提取数据。
这里是Excel的VBA代码，从给定位置提取文本，并将其保存到Sheet1中的Sheet1格中：
Private Sub CommandButton1_Click() ' Create TextExtractor object ' Set extractor = CreateObject("Bytescout.PDFExtractor.TextExtractor") Dim extractor As New Bytescout_PDFExtractor.TextExtractor extractor.RegistrationName = "demo" extractor.RegistrationKey = "demo" ' Load sample PDF document extractor.LoadDocumentFromFile ("c:\sample1.pdf") ' Get page count pageCount = extractor.GetPageCount() Dim wb As Workbook Dim ws As Worksheet Dim TxtRng As Range Set wb = ActiveWorkbook Set ws = wb.Sheets("Sheet1") For i = 0 To pageCount - 1 RectLeft = 10 RectTop = 10 RectWidth = 100 RectHeight = 100 ' check the same text is extracted from returned coordinates extractor.SetExtractionArea RectLeft, RectTop, RectWidth, RectHeight ' extract text from given area extractedText = extractor.GetTextFromPage(i) ' insert rows ' Rows(1).Insert shift:=xlShiftDown ' write cell value Set TxtRng = ws.Range("A" & CStr(i + 2)) TxtRng.Value = extractedText Next Set extractor = Nothing End Sub
披露：我与ByteScout有关