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
|