AW: Kopieren der Unterverzeichnisse ins Masterverzeichnis?
08.12.2019 14:05:45
Sergej
Hallo Karl-Heinz,
ich lese die Pfade und Startdatum aus Zellen. Das funktioniert soweit.
Das was ich als Debug.Print sPfade(i) bekomme, würde ich gerne in Zelle B6 nach unten eintragen.
Sub DateienAusOrdnerZusammenkopieren()
'Kopieren der Ordner (JJJJMMTT) ab bestimmten Ordner zu einem Masterordner
Dim oOrdner As Object, Obj As Object
Dim sMasterPfad As String, sQuellPfad As String, sPfade() As String
Dim Anzahl As Integer, i As Integer, j As Integer
On Error GoTo Fehler
sQuellPfad = Range("B3")
sMasterPfad = Range("B4")
'Ordner löschen
If Dir(sMasterPfad, vbDirectory) "" Then
Set Fs = CreateObject("Scripting.FileSystemObject")
Fs.DeleteFolder sMasterPfad
End If
With CreateObject("Scripting.FileSystemObject")
Anzahl = .Getfolder(sQuellPfad & "\").subfolders.Count
ReDim sPfade(Anzahl + 1)
For Each Obj In .Getfolder(sQuellPfad & "\").subfolders
For i = 0 To Anzahl
If (Obj.Name "") Or i = Anzahl Then
'Platz schaffen durch Verschieben der Einträge im Array
If i > 0 Then
For j = 1 To i
sPfade(j - 1) = sPfade(j)
Next j
sPfade(i) = Obj.Name
End If
Exit For
End If
Next i
Next Obj
'Ordner anlegen
If Dir(sMasterPfad, vbDirectory) = "" Then
MkDir (sMasterPfad)
End If
Dim Startdatum As String
Startdatum = Range("B5")
If Startdatum = "" Then Exit Sub
Shell "explorer.exe /e, " & sMasterPfad & "\", vbMaximizedFocus
For i = 1 To Anzahl
'Hier Einschränkung der Unterordner möglich....
If Val(sPfade(i)) >= Startdatum And sPfade(i) Like "20######" Then
For Each oOrdner In .Getfolder(sQuellPfad & "\" & sPfade(i)).subfolders
'Hier Einschränkung der Unterunterordner möglich (*=alles)
If oOrdner.Name Like "*" Then
If Not .FolderExists(sMasterPfad & "\" & oOrdner.Name) Then .CreateFolder sMasterPfad & _
"\" & oOrdner.Name
'Debug.Print oOrdner.Name
oOrdner.Copy sMasterPfad & "\" & oOrdner.Name
Debug.Print sPfade(i)
End If
Next
End If
Next
End With
Set oOrdner = Nothing
MsgBox "Fertig", vbOKOnly Or vbInformation, "Kopieren"
Exit Sub
Fehler:
MsgBox "Es ist der Fehler '" & Error & "' aufgetreten!", vbOKOnly Or vbExclamation, "Kopieren""" _
End Sub
Beste Grüße,
Sergej