Inhalte von einer PDF suchen und den Text kopieren

Sub PDFtoExcel()
Dim i As Integer, z As Long
Dim strCMDLine As String, strTXT As String
Dim FSO As Object, objSFold As Object, objWks As Object, WshShell As Object, tmp As Object
Dim colPFiles As New Collection, colTFiles As New Collection
Set WshShell = CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objSFold = FSO.GetFolder(ThisWorkbook.Path)
Set objWks = ThisWorkbook.Sheets(1)                             ' Ausgabe
strCMDLine = ThisWorkbook.Path & "\Tools\pdftotext.exe -raw -layout -nopgbrk "
Const strPrefix As String * 31 = "Name"
Const intSWLen = 20
For Each tmp In objSFold.Files                                  ' alle Dateien einlesen
If Right(tmp.Path, 4) = ".pdf" Then colPFiles.Add tmp.Path  ' nur *.pdf
Next tmp
For i = 1 To colPFiles.Count
WshShell.Run (strCMDLine & Chr(34) & colPFiles.Item(i) & Chr(34)), 0, True
'        Kill colPFiles.Item(i)                                      ' pdf-Files löschen
Next
For Each tmp In objSFold.Files                                  ' wieder alles einlesen
If Right(tmp.Path, 4) = ".txt" Then colTFiles.Add tmp.Path  ' nur *.txt
Next tmp
z = objWks.Cells(Rows.Count, 1).End(xlUp).Row + 1               ' letzte belegte Zeile ( _
Spalte A)
For i = 1 To colTFiles.Count
strTXT = FSO.OpenTextFile(colTFiles.Item(i)).ReadAll
objWks.Cells(z, 3) = colPFiles.Item(i)                      ' Dateiname in Spalte B
objWks.Cells(z, 4) = 1
While InStr(1, strTXT, strPrefix, vbTextCompare) > 0
strTXT = Mid(strTXT, InStr(1, strTXT, strPrefix) + Len(strPrefix) - 1)
objWks.Cells(z, 2) = Left(strTXT, intSWLen)             ' Wert eintragen
z = z + 1
Wend
Kill colTFiles.Item(i)                                      ' txt-Files löschen
Next
End Sub