Office: Datei in alle Unterordner kopieren

xlph · 5. Juli 2016

Code:

Public Sub xlph_TEST()
Call FileCopyTo("C:\Test\abcdef.xlsx", "E:\Test")
End Sub

Public Sub FileCopyTo(ByVal strFilePath As String, ByVal strTargetPath As String)

Dim fso As Object

Dim strFile As String

Dim colTargetPath As Collection

Dim icol As Long

Set colTargetPath = New Collection

If Right(strTargetPath, 1) = "\" Then
strTargetPath = Left(strTargetPath, Len(strTargetPath) - 1)
End If

strFile = Dir(strFilePath)

Set fso = CreateObject("Scripting.FileSystemObject")

Call OrdnerListen(fso, strTargetPath, colTargetPath)

For icol = 1 To colTargetPath.Count
fso.CopyFile strFilePath, colTargetPath(icol) & "\" & strFile
Next

Set fso = Nothing
Set colTargetPath = Nothing

End Sub

Private Sub OrdnerListen(fso As Object, ByVal strFolderPath As String, col As Collection)
Dim o, uo

col.Add strFolderPath

Set o = fso.GetFolder(strFolderPath)

For Each uo In o.SubFolders
Call OrdnerListen(fso, uo.Path, col)
Next

Set o = Nothing
Set uo = Nothing

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Sputnik0412 · 5. Juli 2016

Moin, moin,
so, ich schau mal, wann ich zum Testen komme *biggrin.gif*.

Erst mal vorab @xlph: Die Unterordner im Zielordner werden jeweils neu erstellt, richtig.

VG
sputnik

Sputnik0412 · 5. Juli 2016

\@ earlfred: Den von dir genannten Fehler bekomme ich nicht - dafür wieder die 424 in der If-Abfrage des zweiten Makros *frown.gif*.

Option Explicit habe ich automatisch aktiviert (Excel 2010).
Der Code sieht nun wie folgt aus:

Code:

Sub start()

Dim f As Object
Dim fso As Object
Dim strQuelldateiPfad As String, strDateiName As String, strZieldateiPfad As String

strQuelldateiPfad = "I:\LOG_2\Produktverpackung-Schenker\6_Prozesse - Arbeitsunterlagen - Anweisungen\Prozesse und Schulungsvorlagen\Pflege von Verpackungsvorschriften\Quellordner\" 'anpassen!
strZieldateiPfad = "I:\LOG_2\Produktverpackung-Schenker\6_Prozesse - Arbeitsunterlagen - Anweisungen\Prozesse und Schulungsvorlagen\Pflege von Verpackungsvorschriften\Zielordner\"
strDateiName = "A101.xlsx" 'anpassen!

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(strZieldateiPfad)

Call kopiereInAlleUnterverzeichnisse(foVerzeichnis:=f, strQuelldateiPfad:=strQuelldateiPfad, strDateiName:=strDateiName)

Set f = Nothing
Set fso = Nothing

End Sub

Private Sub kopiereInAlleUnterverzeichnisse(ByRef foVerzeichnis As Object, ByRef strQuelldateiPfad As String, ByRef strDateiName As String)
Dim sf As Object
If foVerzeichnis.Path & "\" strQuelldateiPfad Then fso.CopyFile strQuelldateiPfad & "\" & strDateiName, foVerzeichnis.Path & "\" & strDateiName
For Each sf In foVerzeichnis.SubFolders
Call kopiereInAlleUnterverzeichnisse(sf, strQuelldateiPfad, strDateiName)
Next sf
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

@xlph: Deinen Code muss ich mir später mal ausführlich anschauen - danke erst mal *Smilie

xlph · 5. Juli 2016

@xlph: Deinen Code muss ich mir später mal ausführlich anschauen - danke erst mal
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

...einfach testen.

EarlFred · 5. Juli 2016

Hallo Sputnik,

Den von dir genannten Fehler bekomme ich nicht
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

nein. Mit dem jetzigen Code vermutlich nicht. Mit dem Code, den Du davor gepostet hast und auf den ich mich bezogen habe, schon. Du musst schon über das gleiche reden.

Option Explicit
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

wenn Du tatsächlich Option Explicit im Modul aktiviert hättest, würde die Sub kopiereInAlleUnterverzeichnisse aus Beitrag #18 überhaupt nicht starten, weil nämlich eine Variable dort unbekannt/ nicht deklariert ist. Ohne Option Explicit läuft der Code hingegen an und meldet tatsächlich (logischerweise) den von Dir genannten Fehler, allerdings im Then-Teil, also fso.CopyFile strQuelldateiPfad & "\" & strDateiName, foVerzeichnis.Path & "\" & strDateiName (diese Information hätte von Dir kommen müssen, weil es die Aufmerksamkeit auf die richtige Stelle lenkt und nicht irreführend auf den If-Teil).

Und jetzt schau Dir abschließend mal meinen Code an und dann Deinen. Worauf Du zu achten hast, verrät Dir Option Explicit, wenn Du es tatsächlich mal setzen würdest.
Das ist eigentlich alles das gleiche, was Du schon im Beitrag #13 als Hinweis erhalten hast.

Der Basiscode, über den ich rede, steht in Beitrag #8 (ohne Fehlermeldung, dafür mit Option Explicit und für das Funktionieren richtiger und vollständiger Variablendeklaration) und hätte nur in einer einzigen (optional: 3) Zeile, wie im Beitrag #10 benannt, geändert werden müssen. Das kann doch wirklich nicht so schwer sein.

Code:

Option Explicit

Public fso As Object

Sub start()
Dim f As Object
Dim strQuelldateiPfad As String, strDateiName As String
Dim strZieldateiPfad As String 'neu / Optional bei Verwendung einer eigenen Variable

strZieldateiPfad = "LaufwerkZiel:\VerzeichnisZiel" 'anpassen! neu / Optional bei Verwendung einer eigenen Variable
strQuelldateiPfad = "LaufwerkQuelle:\VerzeichnisQuelle" 'anpassen!
strDateiName = "Dateiname.Endung" 'anpassen!

Set fso = CreateObject("Scripting.FileSystemObject")

Set f = fso.GetFolder(strZieldateiPfad) 'geändert / optional: harter Eintrag das Pfades

Call kopiereInAlleUnterverzeichnisse(foVerzeichnis:=f, strQuelldateiPfad:=strQuelldateiPfad, strDateiName:=strDateiName)

Set f = Nothing
Set fso = Nothing
End Sub

Private Sub kopiereInAlleUnterverzeichnisse(ByRef foVerzeichnis As Object, ByRef strQuelldateiPfad As String, ByRef strDateiName As String)
Dim sf As Object
If foVerzeichnis.Path & "\" strQuelldateiPfad Then fso.CopyFile strQuelldateiPfad & "\" & strDateiName, foVerzeichnis.Path & "\" & strDateiName
For Each sf In foVerzeichnis.SubFolders
Call kopiereInAlleUnterverzeichnisse(sf, strQuelldateiPfad, strDateiName)
Next sf
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Grüße
EarlFred

Sputnik0412 · 5. Juli 2016

Hallo noch mal,

entschuldige meine Fehler. Scheinbar habe ich die Nerven genug strapaziert

Und doch: Es kann so schwer sein - ich arbeite seit ca. 2 Wochen nebenher am Thema VBA.

Sputnik0412 · 6. Juli 2016

Habe jetzt auch die anderen Makros getestet:

@haklesoft + xlph: Funktionieren perfekt - machen genau das was es soll *Smilie.

Ich danke euch sehr!

Fennek11 · 6. Juli 2016

Hallo,

ich habe die Frage und Antworten nur sehr oberflächlich verfolgt, aber trotzdem einen Kommentar.

Mit
cmd: dir /a:d /s
können alle Unterverzeichnisse gelistet werden. Daher sollte auch funktionieren

sPath = "c:\temp\"
ar = split(createobject("wscript.shell").exec("cmd /c dir " & sPath & "/b /a:d /s").stdout.readall, vbcrlf)

Im array ar stehen alle Unterverzeichnisse. Der rekursive Aufruf ist damit entbehrlich.

mfg

Office: Datei in alle Unterordner kopieren

Datei in alle Unterordner kopieren

Datei in alle Unterordner kopieren

Datei in alle Unterordner kopieren

Datei in alle Unterordner kopieren

Datei in alle Unterordner kopieren - Similar Threads - Datei Unterordner kopieren

Makros für die neueste Datei in Unterordner ausführen

Ordner und Unterordner auslesen mit Anzahl der Unterordner/Dateien pro Ordner

Alle Dateien in den Unterordnern löschen

Excel Zellen aus vielen Dateien auslesen inkl. Unterordner

neueste Datei in Unterordnern suchen und importieren

Ordner mit allen Unterordnern und Dateien in neuen Ordner kopieren

VBA: Dateien auflisten aus den Unterordnern des aktuellen Ordners (1. Ebene)