@Uduuh, nochmal Kopierorgie

Sub CopyFolders()
Dim oFS As Object, oFolder As Object, oFolder2 As Object
Dim n As Long, strZiel As String
strZiel = "n:\test2"
Set oFS = CreateObject("scripting.filesystemobject")
Set oFolder = oFS.getfolder("c:\temp")
If Dir(strZiel, vbDirectory) = "" Then
MkDir strZiel
End If
With Sheets(1)
For n = 1 To .Cells(65536, 2).End(xlUp).Row
If .Cells(n, 1) = 1 Then
Set oFolder2 = oFS.getfolder(.Cells(n, 2))
If Dir(strZiel & "\" & oFolder2.parentfolder.Name, vbDirectory) = "" Then
MkDir strZiel & "\" & oFolder2.parentfolder.Name
'und hier jetzt noch eine *.* Filecopy von Parent folder zu neuem Parent folder
End If
oFolder2.Copy strZiel & "\" & oFolder2.parentfolder.Name & "\"
.Cells(n, 1) = "x"
End If
Next
End With
End Sub