AW: VBA - Alle Dateien in Unterordner kopieren
04.10.2007 20:16:00
Tino
Hallo,
hier die angepasste Variante, bei dieser musst du
den Pfad nicht mehr angeben.
Aber die Excel-Datei,
muss in dem Ordner gespeichert sein
wo sich die besagten Unterordner befinden!!!!!
Sub neu()
Dim i As Variant, unterordner As Variant
Dim fso, f1 As Object
Dim strDateiName As String, verz As String
verz = ActiveWorkbook.Path & "\" 'Kopieren von
Set fso = CreateObject("Scripting.filesystemobject")
Set f1 = fso.GetFolder(verz)
ChDir verz
With Application.FileSearch
.NewSearch
.LookIn = verz
.SearchSubFolders = False
.Filename = "*.*" 'Datei Typ
.Execute
For Each unterordner In f1.subfolders
For i = 1 To .FoundFiles.Count
'hier Dateinamen extrahieren
strDateiName = Right(.FoundFiles(i), Len(.FoundFiles(i)) - InStrRev(.FoundFiles(i), "\"))
'und hier kopieren
If strDateiName = ActiveWorkbook.Name Then GoTo nächste:
FileCopy .FoundFiles(i), unterordner & "\" & strDateiName
nächste:
Next i
Next unterordner
End With
Set fso = Nothing
Set f1 = Nothing
End Sub
Gruss
Tino