Daten aus PDF auslesen und per VBA in Excel schreiben

Sub PDF2Excel()
    Dim i As Integer
    Dim strCMDLine As String, strTXT As String
    Dim FSO As Object, objSFold As Object, objWks As Object, WSHShell As Object, file As Object, rngLastRow As Range
    Dim colPFiles As New Collection, colTFiles As New Collection, regex As Object
    
    ' Objects erstellen  
    Set WSHShell = CreateObject("WScript.Shell")  
    Set FSO = CreateObject("Scripting.FileSystemObject")  
    Set regex = CreateObject("vbscript.regexp")  
    
    ' Regex Options  
    regex.MultiLine = True: regex.Global = True: regex.IgnoreCase = True
    
    Set objSFold = FSO.GetFolder(ThisWorkbook.Path)
    
    strCMDLine = """D:\Download\pdftk\pdftotext.exe"" -raw -nopgbrk "  
        
    For Each file In objSFold.Files                                  ' alle Dateien einlesen  
        If Right(file.Path, 4) = ".pdf" Then colPFiles.Add file.Path  ' nur *.pdf  
    Next

    For i = 1 To colPFiles.Count
         WSHShell.Run strCMDLine & """" & colPFiles.Item(i) & """", 0, True  
    Next

    For Each file In objSFold.Files                                  ' wieder alles einlesen  
        If LCase(Right(file.Path, 4)) = ".txt" Then colTFiles.Add file.Path  ' nur *.txt  
    Next
    
    Set objWks = Worksheets(1)
    Set rngLastRow = objWks.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    
    For i = 1 To colTFiles.Count
        strTXT = FSO.OpenTextFile(colTFiles.Item(i)).ReadAll
        ' Ärzte auslesen  
        regex.Pattern = "(^.+)[\r\n]*((^(Hausarzt|Fachärztin|Facharzt)[\r\n]+)?^(Facharzt|Fachärztin|Hausarzt) .*?)[\s\S]+?^(.*)[\r\n]+^(\d{5}) (.*)[\s\S]*?^Tel\.: (.*)"  
        Set matches = regex.Execute(strTXT)
        If matches.Count > 0 Then
            For Each m In matches
                rngLastRow.Cells(1, 1).Value = Trim(m.submatches(0)) ' Name des Arztes  
                rngLastRow.Cells(1, 2).Value = Trim(m.submatches(4)) ' Art des Arztes  
                rngLastRow.Cells(1, 3).Value = Trim(m.submatches(5)) ' Adresse  
                rngLastRow.Cells(1, 4).Value = Trim(m.submatches(6)) ' PLZ  
                rngLastRow.Cells(1, 5).Value = Trim(m.submatches(7)) ' Ort  
                rngLastRow.Cells(1, 6).Value = Trim(m.submatches(8)) ' Telefonnummer  
                Set rngLastRow = rngLastRow.Offset(1, 0)
            Next
        End If
        
        'Textdatei löschen  
        Kill colTFiles.Item(i)
    Next
    Set FSO = Nothing
    Set regex = Nothing
    Set WSHShell = Nothing
    Set objSFold = Nothing
End Sub