VB Text aus PDF Dateien extrahieren

Zur Navigation springen Zur Suche springen
Mittels Excel-VBA den Text aus PDF-Dateien in Excel-Dateien speichern

Voraussetzung

Das Freeware-Tool Pdf2totext herunterladen und die Datei pdftotext.exe in ein Verzeichnis entpacken, Installation ist nicht erforderlich.

Aufbau des Excel-Makros

Pdf2text.png

Zunächst erzeugt man mit dem Button PDF Dateien auflisten eine Liste aller PDF-Dateien im angegebenen PDF-Verzeichnis. Diese Angabe ist erforderlich, ansonsten bricht das Programm ohne Aktion ab.

Der Button PDF Inhalte in Excel übertragen bewirkt folgendes: mit dem Freewaretool pdftotext.exe wird der Text aus der PDF-Datei extrahiert und in eine Textdatei geschrieben.

Usage: pdftotext [options] <PDF-file> [<text-file>] -f <int> : first page to convert -l <int> : last page to convert -layout : maintain original physical layout -simple : simple one-column page layout -table : similar to -layout, but optimized for tables -lineprinter : use strict fixed-pitch/height layout -raw : keep strings in content stream order -fixed <number> : assume fixed-pitch (or tabular) text -linespacing <number>: fixed line spacing for LinePrinter mode -clip : separate clipped text -nodiag : discard diagonal text -enc <string> : output text encoding name -eol <string> : output end-of-line convention (unix, dos, or mac) -nopgbrk : don't insert page breaks between pages -bom : insert a Unicode BOM at the start of the text file -marginl <number> : left page margin -marginr <number> : right page margin -margint <number> : top page margin -marginb <number> : bottom page margin -opw <string> : owner password (for encrypted files) -upw <string> : user password (for encrypted files) -q : don't print any messages or errors -cfg <string> : configuration file to use in place of .xpdfrc -v : print copyright and version info -h : print usage information -help : print usage information --help : print usage information -? : print usage information

Für meine Zwecke haben sich folgende Parameter als praktikabel erwiesen:

C:\Programme\tools\pdftotext.exe -raw -nopgbrk -table

Für jede PDF-Datei wird ein eigenes Tabellenblatt angelegt, zusätzlich wird eine Textdatei im Verzeichnis der aufrufenden Excel-Datei abgelegt. Ich habe darauf verzichtet, diesen Pfad variabel zu gestalten.

Mittels Trimlänge wird angegeben, ob vom vorderen Teil der PDF-Namen ein fixer Bestandteil entfernt werden soll, wenn z.B. die PDF-Dateien immer den gleichen Anfang besitzen, z.B. Bericht ...

Das Trennzeichen bewirkt, dass alle nachfolgenden Buchstaben aus dem Dateinamen entfernt werden. Wenn das Trennzeichen fehlt, hat dies keine Auswirkung. Sicherheitshalber werden für die Namen der Tabellenblätter die jeweils ersten 30 Zeichen herangezogen.

Deklarationen

Die Deklarationen lagere ich in einen eigenen Modul aus.
Public Const ToolPath As String = "C:\Programme\tools\pdftotext.exe -raw -nopgbrk -table " ' ein Beispiel für einen möglichen Pfad
' Suchtext für Excel-sheet
Public Const PDFVerzeichnis As String = "PDF-Verzeichnis:"
Public Const PDFDateien As String = "PDF-Dateien:"
Public Const TrimmLen As String = "Trimlänge"
Public Const Trennzeichen As String = "Trennzeichen:"
Public Const SuchText As String = "Suchtext:"

PDF-Dateien auflisten

Grundsätzlich könnte man diesen Schritt auslassen. Ich bevorzuge mehr Kontrollmöglichkeit. Erstens bekommt man einen Überblick, wie viele PDF-Dateien sich in den Ordnern verstecken, und zweitens kann man Werte aus der Liste löschen, falls man diese aus irgendeinem Grund nicht benötigt.
Dim mySh As Worksheet, myRng As Range, myPath As String
  Dim tmpObj As Object
  Dim I As Integer, J As Integer
  Dim FSO As Object, PDFFolder As Object
  Dim myPDFs As New Collection, myTxts As New Collection
  
  Set mySh = ThisWorkbook.Worksheets("PDF Tools")
  
  On Error Resume Next
  ' PDFVerzeichnis und PDFDateien sind als Konstante definiert
  ' enthalten die Beschriftung für die Zelle, wo der
  ' übergeordnete Ordner lokalisiert ist und wo die Liste der gefundenen Dateien abgelegt wird
  ' Public Const PDFVerzeichnis As String = "PDF-Verzeichnis:"
  ' Public Const PDFDateien As String = "PDF-Dateien:"
  
  Set myRng = mySh.Cells.Find(What:=PDFVerzeichnis, After:=Range("A1") _
    , LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Offset(0, 1)
  
  If Err <> 0 Then
    MsgBox "Kein Ordner für PDF-Suchbeginn angegeben, Programm wird beendet"
    Exit Sub
  End If
  
  PDFPath = myRng.Text
  Err.Clear
  
  Set myRng = mySh.Cells.Find(What:=PDFDateien, After:=Range("A1") _
    , LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Offset(0, 1)
  
  If Err <> 0 Then
    MsgBox "In einer Zelle muss stehen: 'PDF-Dateien:'; rechts davon werden die Namen der gefundenen Dateien abgelegt" & Chr(13) & Chr(10) & _
           "keine solche Zelle vorhanden, Programm wird beendet"
    Exit Sub
  End If
  
  Range(myRng, myRng.End(xlDown)).Clear ' vorhandene Liste löschen
  
  If Not FolderDa(PDFPath) Then
    PDFPath = ThisWorkbook.Path ' Standardverzeichnis ist das aktive Verzeichnis
    
  End If
  Dim FileSystem As Object
  Set FileSystem = CreateObject("Scripting.FileSystemObject")
  Set PDFFolder = FileSystem.GetFolder(PDFPath)
  Set myPDFs = Nothing
  DoFolder PDFFolder, myPDFs
  'Set myPDFs = DoFolder(PDFFolder)
  'For Each tmpObj In PDFFolder.Files
    'If LCase(Right(tmpObj.Path, 4)) = ".pdf" Then myPDFs.Add tmpObj
  'Next tmpObj
 
  For I = 1 To myPDFs.Count
    mySh.Cells(myRng.Row + I - 1, myRng.Column) = myPDFs.Item(I)
  Next I

PDF-Dateien als Text speichern und in Excel-Sheets kopieren

Die zuvor erstellten Liste wird abgearbeitet
' Zahlenwerte der PDF Dateien analysieren
  Dim mySh As Worksheet, myRng As Range, sRng As Range
  
  Dim I As Long, J As Long, cPDF As Integer, K As Long
  Dim soSh As Worksheet, soRng As Range
  Dim PDFName() As String                    ' Name der PDF-Dateien
  Dim txtWb As Workbook, txtSh As Worksheet  ' Workbook und Worksheet des Textes
  Dim nWb As Workbook, nSh As Worksheet      ' Resultatworkbook
  Dim myPath As String, trimLen As Integer
  Dim trennC As String, suchTxt As String
  
  On Error Resume Next
  
  Set mySh = ThisWorkbook.Worksheets("PDF Tools")
  myPath = ThisWorkbook.Path & "\"

  Set myRng = mySh.Cells.Find(What:=PDFDateien, After:=Range("A6") _
    , LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Offset(0, 1)
  
  If Err <> 0 Then
    MsgBox "Liste der PDF-Dateien nicht gefunden, diese sollte rechts von der Zelle" & Chr(13) & Chr(10) & _
    "mit der Beschriftung 'PDF-Dateien:' stehen, Programm wird beendet"
    Exit Sub
  End If

  ' Trennzeichen zum Abtrennen von hinteren Namensbestandteilen suchen
  Set sRng = Nothing
  Set sRng = mySh.Cells.Find(What:=Trennzeichen, After:=Range("A6") _
    , LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Offset(0, 1)
    
  trennC = ""
  If Not sRng Is Nothing Then
    trennC = sRng.Text
  End If
  
  ' Suchtext suchen
  Set sRng = Nothing
  Set sRng = mySh.Cells.Find(What:=SuchText, After:=Range("A6") _
    , LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Offset(0, 1)
    
  suchTxt = ""
  If Not sRng Is Nothing Then
    suchTxt = sRng.Text
  End If
  
  ' Trimlänge
  Set sRng = Nothing
  Set sRng = mySh.Cells.Find(What:=TrimmLen, After:=Range("A6") _
    , LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False).Offset(0, 1)
    
  trimLen = 16
  If Not sRng Is Nothing Then
    trimLen = sRng.Value
  End If
  
  cPDF = myRng.End(xlDown).Row - myRng.Row + 1 ' Anzahl der zu analysierneden PDFs
  If Err <> 0 Then
    cPDF = 1
    Err.Clear
  End If
  
  ReDim PDFName(cPDF)
  
  On Error Resume Next
  Set nWb = Workbooks.Add
  Set nSh = nWb.ActiveSheet

  ' in die erste Tabelle schreiben wir Informationen darüber, was eigentlich passiert ist
  ' wenn z.B. die Suche ohne Ergebnis war, kennt man sich sonst nicht aus

  Dim HinWeis As String, pdfs()
  nSh.Range("a1") = "Text aus PDF-Dateien"
  HinWeis = "alle PDF-Dateien"
  If suchTxt > " " Then
    HinWeis = HinWeis & ", die den Text '" & suchTxt & "' enthalten,"
  End If
  nSh.Range("a2") = HinWeis & " werden aufgelistet"

  pdfs = Application.Transpose(Range(Cells(myRng.Row, myRng.Column), Cells(myRng.Row + cPDF - 1, myRng.Column)).Value)
  nSh.Range("a4") = "Liste der PDF-Dateien (" & UBound(pdfs) & " Stück)"
  For I = 0 To UBound(pdfs) - 1
    nSh.Cells(I + 5, 1) = pdfs(I)
  Next I
  
  Dim TextName As String, TextFileName As String, SoName As String, FileName As String, SheetName As String
  Application.EnableEvents = False
  Application.DisplayAlerts = False
  For I = 1 To cPDF
    J = I + myRng.Row - 1
    FileName = mySh.Cells(J, myRng.Column).Text
    
    TextName = Mid(FileName, InStrRev(FileName, "\") + 1, InStrRev(FileName, ".") - InStrRev(FileName, "\") - 1)
    'TextFileName = myPath & Right(TextName, Len(TextName) - 16) & ".txt"
    SoName = Right(TextName, Len(TextName) - trimLen)
    SoName = Trim(Replace(Left(SoName, InStrRev(SoName, trennC) - 1), ".", ""))
    SoName = Replace(Replace(Replace(Replace(SoName, "ö", "oe"), "ü", "ue"), "ä", "ae"), "ß", "ss")
    SoName = Replace(Replace(Replace(SoName, "Ä", "Ae"), "Ö", "Oe"), "Ü", "Ue")
    TextFileName = myPath & SoName & ".txt"
    Application.ScreenUpdating = True
    Application.StatusBar = TextFileName
    Application.ScreenUpdating = False
    SheetName = Left(SoName, 30)
    Set soSh = Nothing
    Set soSh = nWb.Worksheets(SheetName)
    Err.Clear
   
    'Ergebnis = Shell(ToolPath & Chr(34) & Filename & Chr(34) & TextFileName & Chr(34))
    Ergebnis = Shell(ToolPath & """" & FileName & """ """ & TextFileName & """")
    Application.Wait (Now() + TimeValue("00:00:01")) ' eine Sekunde Verzögerung je Durchgang, sonst hängt sich Excel irgendwann auf, zumindest auf meinem PC

    ' das als Text gespeicherte PDF-Dokument als Excel öffnen
    Workbooks.OpenText FileName:=TextFileName, Origin:=xlWindows, _
    StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
    ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
    Space:=False, Other:=False
    Set txtWb = ActiveWorkbook
    
    Set sRng = Nothing
    Set sRng = txtWb.ActiveSheet.Cells.Find(What:=suchTxt, After:=Range("A1"), LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
    If Not sRng Is Nothing Then
      ' Suchtext wurde gefunden
      If soSh Is Nothing Then ' Worksheet schon vorhanden
        Set soSh = nWb.Worksheets.Add(After:=nWb.Worksheets(nWb.Worksheets.Count))
        soSh.Name = SheetName
        soSh.Cells(1, 1) = TextName
        Set soRng = soSh.Cells(3, 1)
      Else
        Set soRng = soSh.UsedRange.SpecialCells(xlCellTypeLastCell).Offset(2, 0)
        Set soRng = soSh.Cells(soRng.Row, 1)
        soRng = TextName
        Set soRng = soRng.Offset(2, 0)
      End If
      
      With soRng.Offset(-2, 0).Font
        .Name = "Arial Black"
        .Size = 14
      End With
          
      ActiveSheet.UsedRange.Select
      Selection.Copy
      soSh.Activate
      soRng.PasteSpecial
    End If
    txtWb.Close (False)
    Application.CutCopyMode = False
    soSh.Cells(1, 1).Activate
    
  Next I
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.DisplayAlerts = True
  Application.StatusBar = "Alle PDF-Dateien aus dem Verzeichnis übertragen"

Alle Excel-Dateien ohne Nachfrage schließen

Achtung, nicht gespeicherte Daten gehen verloren
Private Sub CloseAll()
  Dim Wb As Workbook
  
  For Each Wb In Application.Workbooks
    If Wb.Name <> ThisWorkbook.Name Then Wb.Close False
  Next Wb
End Sub

Unterprogramm

Private Sub DoFolder(Folder, Coll)
  Dim tmpObj
  Set tmpObj = Nothing
  Dim SubFolder
  For Each SubFolder In Folder.SubFolders
    DoFolder SubFolder, Coll
  Next
  
  Dim File
  For Each File In Folder.Files
    If LCase(Right(File.Path, 4)) = ".pdf" Then Coll.Add File
  Next
  
End Sub