joha1908
Goto Top

Einzelne Begriffe aus PDF in Excel per VBA auslesen

Hallo zusammen,

ich verwende das folgende Skript PDF auslesen und per VBA in Excel schreiben, um bestimmte Begriffe aus meiner PDF-Datei auszulesen und in eine Excel-Tabelle zu übertragen.
Bei meinen PDFs handelt es sich um Bestellungen. Die Struktur/Aufbau der PDFs macht mir dabei Schwierigkeiten.

Die Bestellung sieht folgendermaßen aus:
Pos Artikel                                                                    Menge ME                             
                                                                                                 
01 X123456789                                                                  30 Stück
     Artikel 456 mit ABC
     Entwurf: 2010
     Bereitstellung
     2 St. DEF
     Liefertermin: 20.04.15

02 X012345678                                                                 30 Stück
     Artikel 123 mit ABC
     Entwurf: 2010
     Bereitstellung
     2 St. DEF
     Liefertermin: 11.07.15


Nun möchte ich von jeder Position (01, 02, ..., n) den Artikelname, den Liefertermin und wenn möglich die Stückzahl in eine Excel-Tabelle übertragen.
Momenten sieht es so aus, dass ich erst einzeln nach jeder Position von 01 ... n suche:

'Bestellung Pos.01 auslesen  
        regex.Pattern = "^01 ([^\r\n]+)"  
        Set matches = regex.Execute(strTXT)
        If matches.Count > 0 Then
            rngLastRow.Cells(2, 1).Value = matches(0).submatches(0) 'Artikel in Spalte A schreiben  
        End If
        
        'Bestellung Pos.02 auslesen  
        regex.Pattern = "^02 ([^\r\n]+)"  
        Set matches = regex.Execute(strTXT)
        If matches.Count > 0 Then
            rngLastRow.Cells(3, 1).Value = matches(0).submatches(0) 'Artikel in Spalte A schreiben  
        End If

...

Geht das auch einfacher?

Dann suche ich nach allen Lieferterminen und sortiere diese der Reihe nach in die Zeilen ein (neben den zugehörigen Pos.-Nr. 01, 02, ...; bedingt durch die Reihenfolge der Pos.-Abfrage oben):

' Liefertermin auslesen  
        regex.Pattern = "Liefertermin: ([^\r\n]+)"  
        regex.Global = True
        regex.MultiLine = True
        Set matches = regex.Execute(strTXT)
        i = 2
        For Each Match In matches
            rngLastRow.Cells(i, 2).Value = Match.submatches(0) 
            i = i + 1
        Next

Was muss ich machen, damit nur der Artikelname oder nur der Liefertermin extrahiert wird, ohne die komplette Zeile dahinter?
Bei der Generierung der txt-Datei werden auch manchmal die Stückzahlen nicht neben die zugehörige Pos.-Nr. geschrieben, sondern weiter oben!? Das macht das ganze echt schwierig.


Kann mir jemand weiterhelfen?
Vielen Dank

Gruß
Joha

Content-Key: 301368

Url: https://administrator.de/contentid/301368

Ausgedruckt am: 29.03.2024 um 12:03 Uhr

Mitglied: 116301
116301 09.04.2016, aktualisiert am 15.04.2016 um 09:33:45 Uhr
Goto Top
Hallo Joha!

Anhand Deines Beispieltextes sollte es so gehen:
Sub PDF2Excel() 
    '.........  

    arrValues = GetMatchValues(FSO.OpenTextFile(colTFiles.Item(i)).ReadAll)
    
    If IsArray(arrValues) Then
        intNextLine = Cells(Rows.Count, "A").End(xlUp).Row + 1  
        Cells(intNextLine, "A").Resize(UBound(arrValues, 1) + 1, UBound(arrValues, 2) + 1).Value = arrValues  
    Else
        'keine treffer  
    End If
    
    '.....  
End Sub

Private Function GetMatchValues(ByRef strText) As Variant
    Dim objMatches As Object, arrValues As Variant, i As Long
    
    With CreateObject("VBScript.RegExp")  
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = "^\d+\s+(\w+)\s+(\d+)\s+St.*\s+([^\r.]+)\s+.*\s+.*\s+.*\s+Liefertermin:\s+([\.\d]+)"  
         Set objMatches = .Execute(strText)
    End With

    If objMatches.Count Then
        ReDim arrValues(0 To objMatches.Count - 1, 0 To 3)
        
        For i = 0 To UBound(arrValues)
            arrValues(i, 0) = objMatches(i).SubMatches(0)           'Artikelnummer  
            arrValues(i, 1) = Trim(objMatches(i).SubMatches(2))     'Artikel  
            arrValues(i, 2) = CLng(objMatches(i).SubMatches(1))     'Menge  
            arrValues(i, 3) = CDate(objMatches(i).SubMatches(3))    'Termin  
        Next
        GetMatchValues = arrValues
    End If
End Function

Gruß Dieter

[edit] Code an die neue Vorlage (weiter unten) angepasst [/edit]
Mitglied: joha1908
joha1908 10.04.2016 aktualisiert um 00:28:46 Uhr
Goto Top
Hallo Dieter,

vielen Dank für deine Antwort.

Das Problem ist, dass die Zeilenzahl zwischen Artikelname und Liefertermin variiert und nicht jedes mal gleich ist.
Auch steht die Stückzahl nicht immer in der gleichen Zeile/Spalte...

Gibt es daür auch Möglichkeiten?

Gruß
Joha
Mitglied: 116301
Lösung 116301 10.04.2016 um 09:56:52 Uhr
Goto Top
Hallo Joha!

Ist die Frage, ob die Daten in der Pdf-Datei auch verschoben sind? Wenn nein, dann könntest Du bei der PdfToText mal die Option (-raw) weglassen und schauen, ob die Text-Dateien anders/besser aussehen...Ansonsten mal mit 3 Matches-Objecten versuchen:
Private Function GetMatchValues(ByRef strText) As Variant
    Dim objMatchesA As Object, objMatchesM As Object, objMatchesT As Object
    Dim arrValues As Variant, i As Long
    
    With CreateObject("VBScript.RegExp")  
        .Global = True
        .MultiLine = True
        .Pattern = "^\d+\s+\w+.*\n\s+([^\r]+)"  'Artikel  
         Set objMatchesA = .Execute(strText)
        .Pattern = "\s+(\d+)\s+Stück"           'Menge  
         Set objMatchesM = .Execute(strText)
        .Pattern = "Liefertermin:\s+([\.\d]+)"  'Termin  
         Set objMatchesT = .Execute(strText)
    End With

    If objMatchesA.Count Then
        If objMatchesA.Count = objMatchesM.Count And objMatchesA.Count = objMatchesT.Count Then
            ReDim arrValues(0 To objMatchesA.Count - 1, 0 To 2)
            
            For i = 0 To UBound(arrValues)
                arrValues(i, 0) = Trim(objMatchesA(i).SubMatches(0))     'Artikel  
                arrValues(i, 1) = CLng(objMatchesM(i).SubMatches(0))     'Menge  
                arrValues(i, 2) = CDate(objMatchesT(i).SubMatches(0))    'Termin  
            Next
            GetMatchValues = arrValues
        End If
    End If
End Function

Gruß Dieter
Mitglied: 114757
114757 10.04.2016 aktualisiert um 11:09:09 Uhr
Goto Top
Oder mal die Option -table verwenden wie im Beitrag empfohlen wurde.

Gruß jodel32
Mitglied: joha1908
joha1908 14.04.2016 um 16:02:09 Uhr
Goto Top
Hallo Jodel32,

die Option -table hat hat geholfen. Die Stückzahlen etc. sieht nun in der richtigen Zeile.

Danke

Gruß
Joha1908
Mitglied: joha1908
joha1908 14.04.2016 um 16:49:00 Uhr
Goto Top
Hallo Dieter,

deine Prozedur auf mein oben angegebenes Beispiel funktioniert mit der Option -table wunderbar. Vielen Dank dafür!
Allerdings sind in der Bestellung noch weitere Angaben, die ich oben weggelassen habe. Diese führen dazu, dass u.a. die Telefonnr., Bankdaten usw. als Artikelnr. interpretiert werden.
Das ganze Dokument sieht in etwa so aus:
 

Lieferanten-Nr. Bearbeiter/in:    Telefon:      Fax:           E-mail:

12345           xxxx, xxxxxxxx	  01234-123456  01234-234567   xxxx@xxxxxxxx.de

vom: 24.03.15

BESTELLUNG   Nr. 683275

Versandanschrift:                  Firma XXXXXX


Hiermit bestellen wir:

Pos Artikel                             Menge              ME    Einzelpreis

01     X12345678                                      5 Stück      123,45

       Artikel blablabla

       Stand: 2010

       Liefertermin: 20.04.15

02     X23456789                                      5 Stück      123,45

       Artikel blablablablabla

       Stand: 2010

       Liefertermin: 11.05.15


Firma XXXXXX  Telefon: 01234-123456

XXXXXXstraße 1, D-XXXX XXXXXXXX

Bank 123 AG		           Bank 1234

1 123 456 (BLZ 123 456 78)         123 456 78 (BLZ 123 456 78)

SWIFT No. blablablabl              SWIFT No. blablablabl

IBAN DE12345678912345678912        IBAN DE12345678912345678912



Kannst Du mir nochmal helfen?
Perfekt wäre es, wenn bei den einzelnen Positionen die Artikelnr. "X12345..." sowie die Zeile darunter "Artikel blabla..." mit in die excel Tabelle geschrieben wird.

Vielen Dank!

Gruß
Joha1908
Mitglied: 114757
Lösung 114757 14.04.2016 aktualisiert um 18:54:51 Uhr
Goto Top
Zitat von @joha1908:

Hallo Dieter,

deine Prozedur auf mein oben angegebenes Beispiel funktioniert mit der Option -table wunderbar. Vielen Dank dafür!
Allerdings sind in der Bestellung noch weitere Angaben, die ich oben weggelassen habe. Diese führen dazu, dass u.a. die Telefonnr., Bankdaten usw. als Artikelnr. interpretiert werden.
Das ganze Dokument sieht in etwa so aus:

Kannst Du mir nochmal helfen?
Perfekt wäre es, wenn bei den einzelnen Positionen die Artikelnr. "X12345..." sowie die Zeile darunter "Artikel blabla..." mit in die excel Tabelle geschrieben wird.

Das bekommst du z.B. hiermit hin:
Set regex = CreateObject("vbscript.regexp")  
Set fso = CreateObject("Scripting.FileSystemObject")  
regex.Global = True: regex.IgnoreCase = True: regex.MultiLine = True
regex.Pattern = "^(\d+)\s+([^\s]+)\s+(\d+)\s?([^\s]*)\s+([\d\.,]+)([\s\S]+?)(?=^\d+|^Firma)"  
Set matches = regex.Execute(strText)
if matches.count > 0 then
  For Each Match In matches
    'Positionsnummer  
    strPos = CInt(Match.submatches(0))
    'Artikelnummer  
    strArtNr = Match.submatches(1)
    'Menge  
    intMenge = CInt(Match.submatches(2))
    'Einheit  
    strEinheit = Match.submatches(3)
    ' Einzelpreis  
    strEinzelpreis = Match.submatches(4)
    'Beschreibung  
    strBeschreibung = Trim(Replace(Match.submatches(5), vbNewLine, ""))  
    
    'Nur zur Demo in MSGBOX ausgeben  
    MsgBox Join(Array(strPos, strArtNr, intMenge, strEinheit, strEinzelpreis, strBeschreibung), vbNewLine)
Next
else
    msgbox "Kein Match.",vbExclamation  
End if
Die Variablen sollten von selbst sprechen...Damit solltest du also klar kommen face-wink

Gruß jodel32
Mitglied: 116301
116301 15.04.2016 um 08:49:21 Uhr
Goto Top
Hallo zusammen!

Meinen obigen Code habe ich auch entsprechend der neuen Vorlage angepasstface-wink

Gruß Dieter
Mitglied: joha1908
joha1908 15.04.2016 um 09:30:10 Uhr
Goto Top
Hallo Jodel,

vielen Dank!

Habe es mittlerweile hinbekommen face-smile

Gruß
Joha
Mitglied: joha1908
joha1908 15.04.2016 um 12:49:20 Uhr
Goto Top
Hallo Dieter, hallo Jodel,

jetzt hätte ich doch noch eine Frage. Eigentlich möchte ich folgendes erreichen:

E-Mail mit PDF-Anhang in Outlook --> aus PDF die Bestelldaten extrahieren (via pdftotext.exe, Skript von oben) und in eine neue Excel-Datei abspeichern --> Liefertermine je Position in Outlook-Kalender eintragen
1 PDF = 1 Bestellung; 1 Bestellung = Pos. 01, Pos. 02, ..., Pos. n, d.h. n Liefertermine

Also:

  • Ereignis: Outlook empfängt neue E-Mail mit PDF-Anhang und speichert die PDF(s) über Regel + Skript in einem Ordner ab (bereits realisiert, wobei das nur funktioniert, wenn die E-Mail auch wirklich an diesem Outlook als neue E-Mail empfangen wird, d.h. wenn diese zuvor mit einem anderen Mail-Client abgerufen wird (IMAP), erscheint diese nicht mehr als neue E-Mail im Posteingang und die Regel greift nicht...)

  • Aus jeder einzelnen abgelegten PDF soll dann - wie oben - die Bestellung ausgelesen werden: Artikel (Positionen), Menge, Liefertermin und diese Daten in eine Excel-Datei geschrieben werden (also nicht die gleiche wie der VBA-Code, sondern in eine neue Excel-Datei, mit dem Dateinamen der PDF-Bestellung)

  • Aus diesen Daten in der neuen Excel-Datei soll dann je Position bzw. je Liefertermin ein Termin in Outlook generiert werden. Das würde ich gerne so umsetzen:
Public Sub Termine_von_Excel_nach_Outlook_exportieren()
Dim OutApp As Object, apptOutApp As Object

'Termine aus Excel-Sheet lesen  
Range("C2").Select  
Do Until ActiveCell.Value = ""  
  Set OutApp = CreateObject("Outlook.Application")  
  Set apptOutApp = OutApp.CreateItem(1)
  With apptOutApp
    'Termine werden aus den Zellen gelesen  
    .Start = Format(ActiveCell.Value, "dd.mm.yyyy")  
    .Subject = ActiveCell.Offset(0, -2).Value
    'Zusätzlicher Text  
    .Body = ActiveCell.Offset(0, -1).Value & " Stück" & ", " & "Firma XXX"  
    'Ort  
    .Location = ActiveCell.Offset(0, -1).Value & " Stück" & ", " & "Firma XXX"  
    'Ganztägig  
    .AllDayEvent = True
    'Termin speichern  
    .Save
  End With

  'Nächste Zeile auswählen  
  ActiveCell.Offset(1, 0).Select
  Set apptOutApp = Nothing
  Set OutApp = Nothing
Loop
End Sub

Wie würdet Ihr das am geschicktesten umsetzen?
Ist es sinnvoll für jede PDF (Bestellung) einen eigenen Ordner zu erstellen?


Gruß
Joha
Mitglied: 114757
114757 15.04.2016 aktualisiert um 13:00:07 Uhr
Goto Top
Ist es sinnvoll für jede PDF (Bestellung) einen eigenen Ordner zu erstellen?
Würde ich gar nicht machen, sondern die Umwandlung nur in eine temporäre Datei im Temp-Verzeichnis erstellen und Daten auslesen.

Wieso eine Excel-Datei extra als Zwischenschritt erstellen? Du kannst den VBA-Code doch direkt in Outlook einbinden, dort das NewMailEx Event Abfragen und bei jeder neuen Mail prüfen ob Anhang passt, dann die Daten per Regex extrahieren und davon direkt neue Termine in Outlook erstellen und von mir aus zusätzlich die Daten in eine Datenbank (MySQL,Access,SQL-Server ...) schreiben. Excel käme da bei mir gar nicht mehr zum Einsatz.
Mitglied: joha1908
joha1908 15.04.2016 aktualisiert um 14:07:42 Uhr
Goto Top
... das hört sich gut an, nur wie mache ich das?

Den Excel-Export würde ich gerne trotzdem machen, nicht wegen den Terminen, sondern wegen der Datenablage in Tabellen.
Mitglied: 114757
114757 15.04.2016 aktualisiert um 15:03:04 Uhr
Goto Top
Zitat von @joha1908:
... das hört sich gut an, nur wie mache ich das?
Such mal nach NewMailEx hier im Forum und auch hier rein für das extrahieren der Attachments in Outlook:
PDF-Dokument in Tiff konvertieren und in einem Verzeichnis ablegen - als Funktion
Das sollte an Info massig reichen um es zu realisieren.
Mitglied: joha1908
joha1908 17.04.2016 um 12:22:30 Uhr
Goto Top
Hallo Jodel,

leider komme ich nicht weiter.
Die eingehende PDF Datei kann ich zwar im Temp-Verzeichnis abspeichern, das Einlesen der PDF für pdftotext.exe geht schon nicht mehr, geschweige denn daraus einen Termin in Outlook zu generieren face-sad
Anbei mein bisheriger Entwurf:

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

Dim varEntryIDs
Dim objItem
Dim i As Integer
Dim strCMDLine As String, strTempPath As String, strTargetPath As String
Dim att As Attachment
Dim fso As Object, objShell As Object, regex As Object
Dim colPFiles As New Collection, colTFiles As New Collection
        
strCMDLine = "C:\Users\Name\Documents\Test_Makro\pdftotext.exe"" -table -layout -nopgbrk "  
strTargetPath = "C:\Users\Name\Documents\Test_Makro\Ablage"  
    
Set fso = CreateObject("Scripting.FileSystemObject")  
Set objShell = CreateObject("WScript.Shell")  
Set regex = CreateObject("vbscript.regexp")  
regex.MultiLine = True
    
varEntryIDs = Split(EntryIDCollection, ",")  
For i = 0 To UBound(varEntryIDs)
    Set objItem = Application.Session.GetItemFromID(varEntryIDs(i))
    If objItem.Class = olMail Then
        For Each att In objItem.Attachments
            ' Wenn Attachment ein PDF ist dann ...  
        If LCase(fso.GetExtensionName(att.FileName)) = "pdf" Then  
            ' Temporäres Zielverzeichnis des Attachments festlegen  
            strTempPath = Environ("Temp") & "\" & att.FileName  
            ' Zielpfad und Dateiname für die Ziel-Datei festlegen  
            strTargetPath = strTargetPath & "\" & fso.GetBasename(att.FileName) & "_" & Format(Now(), "dd.mm.yyyy") & ".pdf"  
            ' Speichere das Attachment im TEMP-Verzeichnis  
            att.SaveAsFile strTempPath
            ' konvertiere das Attachment in txt  
            objShell.Run strCMDLine & """" & att & """", 0, True  
            ' txt-Datei einlesen  
            ?????????????????????????
            arrValues = GetMatchValues(FSO.OpenTextFile(???????????????.ReadAll)
        End If
        Next
    End If
Next
End Sub
' ------------------------------------------------------  
Public Function GetMatchValues(ByRef strText) As Variant
Dim objMatchesA As Object, objMatchesM As Object, objMatchesT As Object
Dim arrValues As Variant, i As Long
    
With CreateObject("VBScript.RegExp")  
    .Global = True
    .MultiLine = True
    .Pattern = "^\d\d\s+M{1}\d+.*\n\s+([^\r]+)"  'Artikel  
    Set objMatchesA = .Execute(strText)
    .Pattern = "\s+(\d+)\s+Stück"           'Menge  
    Set objMatchesM = .Execute(strText)
    .Pattern = "Liefertermin:\s+([\.\d]+)"  'Termin  
        Set objMatchesT = .Execute(strText)
End With

If objMatchesA.Count Then
    If objMatchesA.Count = objMatchesM.Count And objMatchesA.Count = objMatchesT.Count Then
        ReDim arrValues(0 To objMatchesA.Count - 1, 0 To 2)
            
        For i = 0 To UBound(arrValues)
            arrValues(i, 0) = Trim(objMatchesA(i).SubMatches(0))     'Artikel  
            arrValues(i, 1) = CLng(objMatchesM(i).SubMatches(0))     'Menge  
            arrValues(i, 2) = CDate(objMatchesT(i).SubMatches(0))    'Termin  
        Next
        GetMatchValues = arrValues
    End If
End If
End Function

Kannst du mir weiterhelfen?

Gruß
Joha
Mitglied: 114757
114757 17.04.2016 aktualisiert um 12:34:35 Uhr
Goto Top
Naja in Zeile 11 hast du ja auch zwei Anführungszeichen zu viel drin , da hast du dir den Ursprungscode nicht genau genug angesehen, und wenn du kein Textfile für die Ausgabe von pdftotext definierst liegt das Textfile mit gleichem Namen wie die PDF im Temp-Verzeichnis.
Alles andere mach ich hier nicht mehr kostenlos.
Zum Termine erstellen gibt es hier ebenfalls bereits Code en masse im Forum, einfach mal die Suchfunktion anwerfen!
Mitglied: joha1908
joha1908 17.04.2016, aktualisiert am 18.04.2016 um 07:53:23 Uhr
Goto Top
Hallo Jodel,

ok, verstehe... Bin in VBA leider (bisher) nicht so fit.

Aber irgendwie bekomme ich schon gar keine txt-file-Ausgabe hin, kannst du mir nochmal einen Tipp geben?
So sollte das doch eigentlich passen:
...
strCMDLine = "C:\Users\Name\Documents\Test_Makro\pdftotext.exe -table -layout -nopgbrk "  
...
' konvertiere das Attachment in txt  
            objShell.Run strCMDLine & """" & att & """", 0, True  
            ' txt-Datei einlesen  
            For Each file In fso.GetFolder("C:\Users\Name\AppData\Local\Temp\").Files  
                If file.Name = Left(att.FileName, Len(att.FileName) - 4) & ".txt" Then colTFiles.Add file.Path  '  *.txt-Datei einlesen  
            Next
...

EDIT:
Habs hinbekommen, dass das txt.-file generiert wird und im Temp-Ordner ausgegeben wird....
Mitglied: joha1908
joha1908 22.04.2016 um 09:12:02 Uhr
Goto Top
Hallo zusammen,

mein Skript läuft soweit...

Allerdings habe ich noch immer das Problem, dass wenn eine E-Mail zuvor mit einem anderen Mail-Client abgerufen wird (IMAP), diese dann nicht mehr als neue E-Mail im entsprechenden Outlook-Posteingang erscheint und somit die Prozedur nicht gestartet wird.

Gibt es dafür eine Lösung? Habe bisher nichts gefunden.

Gruß
Joha
Mitglied: joha1908
joha1908 02.05.2016 um 19:18:02 Uhr
Goto Top
Hallo Jodel,

kannst Du mir vllt. doch nochmal weiterhelfen?

Ich habe noch immer das Problem, dass wenn eine E-Mail zuvor mit einem anderen Mail-Client abgerufen wird (alle IMAP), diese Mail dann nicht mehr als neue E-Mail im entsprechenden Outlook-Posteingang erscheint und somit die Prozedur (Application_NewMailEX()) nicht gestartet wird.

Gibt es eine Möglichkeit, dass auch neue, bereits auf einem anderen Gerät gelesene Mails die Prozedur starten?

Vielen Dank.

Gruß
Joha
Mitglied: 114757
114757 02.05.2016 aktualisiert um 20:13:32 Uhr
Goto Top
Mit for each Schleife die Mails im Posteingang durchgehen.
for each mail in Application.Session.Stores("NAMEDESSTORES").GetDefaultFolder(olFolderInbox).Items  
    'mail enthält das item ...  
next
VBA Referenz für Outlook
Mitglied: joha1908
joha1908 09.05.2016 um 14:15:26 Uhr
Goto Top
Hallo zusammen,

leider komme ich an diesem Punkt nicht weiter.

Kann mir jmd. weiterhelfen?

Gruß
Joha