Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
912to916
912to916
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

VBA - Alle Dateien in Unterordner kopieren

VBA - Alle Dateien in Unterordner kopieren
03.10.2007 19:35:00
Fritz_W
Hallo Experten,
ich würde gerne aus einer geöffneten Exceldatei alle Dateien, die sich im Ordner der geöffneten Exceldatei befinden in sämtliche Unterordner dieses Ordners (nicht jedoch in weitere Unterverzeichnisse) kopieren.
Die Exceldatei aus der ich das Makro starte, sollte jedoch nicht kopiert werden.
Für eure Unterstützung bereits an dieser Stelle besten Dank.
mfg
Fritz

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA - Alle Dateien in Unterordner kopieren
04.10.2007 15:11:53
Tino
Hallo Fritz_W,
hier habe ich mal etwas für dich.

Sub neu()
Dim i As Variant, unterordner As Variant
Dim fso, f1 As Object
Dim strDateiName As String
Const verz = "c:\tino\"       '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

Anzeige
AW: VBA - Alle Dateien in Unterordner kopieren
04.10.2007 18:40:54
Fritz_W
Hallo Tino,
bin eben von der Arbeit zurück und freue mich, dass sich doch noch jemand an diese - offensichtlich nicht einfache - Aufgabe gewagt hat. Vielen Dank für Deine Arbeit!!
Ich habe das Makro getestet, leider funktioniert es nicht.
Meine VBA-Kenntnisse reichen jedoch nicht aus, um die Ursache dafür zu erkennen. Das Makro "läuft endlos", und trotzdem wurde nicht eine einzige Datei in einen der - im meinem Testfall - 5 vorhandenen Unterordner kopiert.
Muss ich etwas beachten oder kannst Du Dir das Ganze erklären!
Gruß
Fritz

AW: VBA - Alle Dateien in Unterordner kopieren
04.10.2007 19:06:00
Tino
Hallo,
im Code musst du
c:\tino\ mit dem Pfad ersetzen !! wo deine Excel-Datei !! liegt,
am ende vom Pfad "\" nicht vergessen. (die Excel-Datei muss dort abgespeichert sein!!!)
Mit der Taste F8 kannst du dieses Makro in einzelschritten ausführen.
Bei For i = 1 To .FoundFiles.Count angekommen mit der Maus einfach über unterordner gehen nun müsste der Pfad zum Unterordner angezeigt werden. (alles ok?)
weider mit F8
bei FileCopy .FoundFiles(i), unterordner & "\" & strDateiName angekommen mit der Maus
über strDateiName gehen, nun muss die erste gefundene Dateiname angezeigt werden?
Sollte dies nicht gehen, müsstest du mir die Pfadstrucktur geben damit ich deine verhältnisse nachbauen kann.
MfG
Tino

Anzeige
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

Anzeige
Das war stark!
04.10.2007 20:34:38
Fritz_W
Hallo Tino,
mein Kompliment, funktioniert das jetzt prima!
Tolle Hilfe, vielen Dank!
Schönen Abend noch
Gruß
Fritz

27 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige