Hallo,
nach weiterem such im netz bin ich auf folgenden Code gestoßßen, den ich für meine Zwecke angepasst habe:
Sub aufruf()
quelle = "C:\temp"
ziel = "C:\temp_copy"
DirCopy quelle, ziel
End Sub
' Funktion um alle Dateien eines Ordner zu ermitteln
Private Function ReadFilesFromDir(ByVal sPath As String, _
Optional sFilter As String = "*.*") As Variant
Dim sFilename As String
Dim nCount As Long
ReDim sFiles(0) As String
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
nCount = 0
sFilename = Dir(sPath & sFilter, vbNormal)
While sFilename <> ""
If sFilename <> "." And sFilename <> ".." Then
ReDim Preserve sFiles(nCount)
sFiles(nCount) = sFilename
nCount = nCount + 1
End If
sFilename = Dir
Wend
ReadFilesFromDir = sFiles
End Function
' Funktion, um alle Ordner einer Ebene zu ermitteln
Private Function ReadDirs(ByVal sPath As String) As Variant
Dim sFilename As String
Dim nCount As Long
ReDim sFiles(0) As String
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
nCount = 0
sFilename = Dir(sPath, vbDirectory)
While sFilename <> ""
If sFilename <> "." And sFilename <> ".." And _
GetAttr(sPath & "\" & sFilename) = vbDirectory Then
ReDim Preserve sFiles(nCount)
sFiles(nCount) = sFilename
nCount = nCount + 1
End If
sFilename = Dir
Wend
ReadDirs = sFiles
End Function
' Ordner inkl. aller Dateien und Unterordner kopieren
Public Function DirCopy(ByVal sDir As String, _
ByVal dDir As String)
Dim dcV As Variant, dcI As Integer
On Error Resume Next
' zunächst alle Dateien ermitteln
If sDir = dDir Then Exit Function
dcV = ReadFilesFromDir(sDir)
' Ziel-Verzeichnis erstellen
MkDir LCase(dDir)
' alle Dateien kopieren
For dcI = 0 To UBound(dcV)
FileCopy sDir & "\" & dcV(dcI), LCase(dDir & "\" & dcV(dcI))
Next dcI
' Jetzt alle Unterordner ermitteln und Dateien kopieren
dcV = ReadDirs(sDir)
For dcI = 0 To UBound(dcV)
' Es kann vorkommen, dass jemand den Ordner in sich
' selbst kopieren will - was eine Endlosschleife gäbe:
If dcV(dcI) = "" Then Exit For
' Ziel-Unterordner erstellen:
MkDir LCase(dDir & "\" & dcV(dcI))
' Rekursiver Funktionsaufruf, um den Unterordner
' zu erstellen und die Dateien zu kopieren
DirCopy sDir & "\" & dcV(dcI), dDir & "\" & dcV(dcI)
Next dcI
End Function