Hallo Leute,

leider hat meine Recherche im Netz nicht mein Problem lösen können.

Ich hoffe ich kann mein Problem hier verständlich darstellen:

Ich habe in einem Ordner einige PDF Dateien. Diese sollen anhand vom Dateinamen ermittelt und verschoben werden.

Der Ziel-Ordner (mit gleichem Namen) befindet sich unter verschiedenen Kunden-Ordner eben in deren Unterordner.

Dieser Code erstellt aber einen neuen Ordner mit eben dem entsprechenden Dateinamen. Der Code soll aber im Unterordner den zugehörigen Ordner finden und genau dort hin verschieben. Ich hoffe Ihr könnt mir helfen.

Enum enumAction
    xlCopy = 0
    xlMove = 1
End Enum

Sub DateienVerteilen(ByVal Quelle As String, _
            Optional ByVal Ziel As String, _
            Optional ByVal Action As enumAction = 0, _
            Optional ByVal Überschreiben As Boolean = False)
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim strZiel As String
Dim strPfad As String
Dim msg As Byte
Dim bool As Boolean

Set objFSO = CreateObject("Scripting.Filesystemobject")
If Not objFSO.FolderExists(Quelle) Then MsgBox "Der Ordner '" & Quelle & "' existiert nicht !": Exit Sub
If Not objFSO.FolderExists(Ziel) Then
    msg = MsgBox("Der Ordner '" & Ziel & "' existiert nicht - neu anlegen ?", _
                  vbYesNo Or vbCritical, "Meldung")
    If msg = 7 Then Exit Sub Else MkDir Ziel
End If
Set objFolder = objFSO.GetFolder(Quelle)

If Ziel = "" Then Ziel = Quelle
If Right(Quelle, 1) <> "\" Then Quelle = Quelle & "\"
If Right(Ziel, 1) <> "\" Then Ziel = Ziel & "\"

For Each objFile In objFolder.Files
    strZiel = objFSO.GetBaseName(objFile)
    strPfad = Ziel & strZiel
    If Not objFSO.FolderExists(strPfad) Then MkDir strPfad
   
    If Action = 0 Then
        'kopieren der Datei
        bool = Überschreiben
        If objFSO.FileExists(strPfad & "\" & Dir(objFile)) Then
            If Not Überschreiben Then
                msg = MsgBox("Die Datei existiert bereits - Überschreiben ?", _
                              vbYesNo Or vbCritical, "Meldung")
                If msg = 7 Then GoTo WeiterOhneAktion Else bool = True
            End If
        End If
        objFSO.CopyFile objFile, strPfad & "\", bool
    Else
        'verschieben der Datei
        If objFSO.FileExists(strPfad & "\" & Dir(objFile)) Then
            If Überschreiben Then
                Kill strPfad & "\" & Dir(objFile)
            Else
                msg = MsgBox("Die Datei existiert bereits - Überschreiben ?", _
                              vbYesNo Or vbCritical, "Meldung")
                If msg = 7 Then GoTo WeiterOhneAktion
                Kill strPfad & "\" & Dir(objFile)
            End If
        End If
        objFSO.MoveFile objFile, strPfad & "\" & Dir(objFile, vbDirectory)
    End If
WeiterOhneAktion:
Next objFile
End Sub




Sub Machs()
Call DateienVerteilen(Quelle:="C:\Users\XXX\OneDrive\Documents\Projekte\XXXL\Abteilung\Abteilung01\Schäden\Statusblätter\DATA", _
                      Ziel:="C:\Users\XXX\OneDrive\Documents\Projekte\XXX\Abteilung\Abteilung01\Schäden\Versandschäden\Schäden 2021\" & "", _
                      Action:=xlCopy, _
                      Überschreiben:=False)
End Sub