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
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
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