Beiträge zum Thread: Speichername aus PDF auslesen

Option Explicit



Sub PDF_Dateinamen_Einlesen()



    Dim Ordner As String

    Dim Datei As String

    Dim ws As Worksheet

    Dim Zeile As Long

    Dim Teile() As String



    'Tabelle festlegen

    Set ws = ActiveSheet



    'Überschriften

    ws.Cells.Clear



    ws.Range("A1") = "Kundennummer"

    ws.Range("B1") = "Quittungsnummer"

    ws.Range("C1") = "Anrede"

    ws.Range("D1") = "Vor- und Nachname"

    ws.Range("E1") = "Straße + HsNr"

    ws.Range("F1") = "PLZ + Ort"

    ws.Range("G1") = "Steuernummer"



    Zeile = 2



    'Ordner wählen

    With Application.FileDialog(msoFileDialogFolderPicker)



        .Title = "PDF Ordner wählen"



        If .Show = -1 Then

            Ordner = .SelectedItems(1) & "\"

        Else

            Exit Sub

        End If



    End With



    Application.ScreenUpdating = False



    Datei = Dir(Ordner & "*.pdf")



    Do While Datei <> ""



        'pdf entfernen

        Datei = Left(Datei, Len(Datei) - 4)



        'am Bindestrich trennen

        Teile = Split(Datei, "-")



        If UBound(Teile) >= 5 Then



            ws.Cells(Zeile, 1) = Trim(Teile(0))

            ws.Cells(Zeile, 2) = Trim(Teile(1))

            ws.Cells(Zeile, 3) = Trim(Teile(2))

            ws.Cells(Zeile, 4) = Trim(Teile(3))

            ws.Cells(Zeile, 5) = Trim(Teile(4))

            ws.Cells(Zeile, 6) = Trim(Teile(5))



            If UBound(Teile) >= 6 Then

                ws.Cells(Zeile, 7) = Trim(Teile(6))

            End If



            Zeile = Zeile + 1



        End If



        Datei = Dir



    Loop



    ws.Columns.AutoFit



    Application.ScreenUpdating = True



    MsgBox "Fertig. " & Zeile - 2 & " PDFs eingelesen."



End Sub