pdf sortieren und Ordner erstellen via VBA Button

Hallo zusammen,
ich moechte ein Makro erstellen, um einen Ordner mit mehreren pdf-Dateien zu sortieren und Unterordner zu erstellen.
Es gehoeren immer 3 pdf-Dateien zusammen und sind wie folgt benannt:
X-12345678910.pdf
Y-12345678910.pdf
Z-12345678910.pdf
X-12345678911.pdf
Y-12345678911.pdf
Z-12345678911.pdf
usw.
Mein Plan ist es, mithilfe eines Klicks auf einen Button ein Makro zu starten, was die drei zusammengehoerenden pdf-Dateien anhand der zehnstelligen Nummer erkennt und in einen eigenen Ordner verschiebt. Der Name des neuen Ordners soll aus der zehnstelligen Nummer und dem Erstelldatum bestehen.
Existiert ein Ordner bereits waere eine Fehlermeldung sinnvoll.
Die zehnstelligen Nummern sind dabei variabel.
Im naechsten Schritt moechte ich Informationen (z.B. ein Datum) aus einer dieser PDFs auslesen und bspw. in einer Excelliste einpflegen. Vielleicht mit einem neuen Button.
Ich Weiss allerdings nicht, ob das, aus einer pdf heraus, moeglich ist oder nicht?
Ich versuche mich gerade ein bisschen in das Thema einzulesen, um mir ein gewisses Verstaendnis anzueignen. Moechte meine Kenntnisse gern erweitern.
Ich freue mich sehr ueber Hilfe und Erklaerungen.
Viele Gruesse aus Melbourne
Tom

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

const Pfad as string = "c:\temp\" '>> sub PDF_verschieben() f = dir(Pfad & "*.pdf") do until f = "" Nm = mid(f, 3, 14) if dir(Pfad & Nm, vbDirectory) = "" then Mkdir Pfad & Nm NAME Pfad & f AS Pfad & NM f = dir loop end sub

const Pfad as string = "c:\temp\" '>> sub PDF_verschieben() dim WHS as object set WHS = CreateObject("Shell.Application") f = dir(Pfad & "*.pdf") do until f = "" Nm = mid(f, 3, 14) .NameSpace(Pfad).NewFolder(Nm) NAME Pfad & f AS Pfad & NM f = dir loop set WHS = nothing end sub

Option Explicit Sub alle_Dateien_Verzeichnis() ' On Error GoTo Fehler Dim strPfad As String, strSubPfad As String, strMaske As String, strDatei As String, strDatum As String, strName As String strPfad = "x:\Temp\Test\" '**** mit \ strMaske = "*-*.pdf" 'Datumals Präfix strDatum = Format(Date, "YYYYMMDD") & "_" strDatei = Dir(strPfad & strMaske) Do While Len(strDatei) > 0 strName = Replace(strDatei, ".pdf", "") strName = Mid(strName, InStr(strName, "-") + 1) 'Nur wenn 10 stellige Zahl If IsNumeric(strName) And Len(strName) = 10 Then 'Unterverz anlegen, wenn noch nicht da strSubPfad = strName & "\" If Not PfadVorhanden(strPfad & strSubPfad) Then MkDir strPfad & strSubPfad End If 'Datei verschieben und dabei umbenennen Name strPfad & strDatei As strPfad & strSubPfad & strDatum & strDatei End If strDatei = Dir() ' nächste Datei Loop Err.Clear Fehler: If Err.Number <> 0 Then MsgBox "Fehler: " & _ Err.Number & vbLf & Err.Description: Err.Clear End Sub Public Function PfadVorhanden(strPfad As String) Dim objFSO As Object Set objFSO = CreateObject("Scripting.FileSystemObject") If objFSO.folderExists(strPfad) = True Then PfadVorhanden = True Else PfadVorhanden = False End If Set objFSO = Nothing End Function

Hallo nochmal
eine Sache hab ich noch geändert.
Im Verzeichnisname wird jetzt das Datum angehangen und nicht in der Datei.

Sub alle_Dateien_Verzeichnis() ' 
    On Error GoTo Fehler
    Dim strPfad As String, strSubPfad As String, strMaske As String, strDatei As String, strDatum As String, strName As String
    
    strPfad = "x:\Temp\Test\" '**** mit \ 
    strMaske = "*-*.pdf"
    
    'Datumals Präfix 
    strDatum = Format(Date, "YYYYMMDD")
    
    
    strDatei = Dir(strPfad & strMaske)
    Do While Len(strDatei) > 0
    
        strName = Replace(strDatei, ".pdf", "")
        strName = Mid(strName, InStr(strName, "-") + 1)
        
        'Nur wenn 10 stellige Zahl 
        If IsNumeric(strName) And Len(strName) = 10 Then
            
            'Unterverz anlegen, wenn noch nicht da 
            strSubPfad = strName & "_" & strDatum & "\"
            If Not PfadVorhanden(strPfad & strSubPfad) Then
                MkDir strPfad & strSubPfad
            End If
            
            'Datei verschieben und dabei umbenennen 
            Name strPfad & strDatei As strPfad & strSubPfad & strDatei
        End If
        strDatei = Dir() ' nächste Datei 
    Loop
    
    
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear

End Sub
   
Public Function PfadVorhanden(strPfad As String)
    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If objFSO.folderExists(strPfad) = True Then
        PfadVorhanden = True
    Else
        PfadVorhanden = False
    End If
    Set objFSO = Nothing
End Function