XL 2013 Macro pour recopier des fichiers

[océanne]

Bonjour à tous,

je vous sollicite pour le besoin suivant :
j'ai besoin de recopier de très nombreux fichiers (.pdf, .docx., .xls, .jpg etc..) qui sont contenus dans un répertoire et des sous-répertoires vers un seul répertoire.
Je me suis appuyé sur cette macro ci-contre, qui marche très bien :
Dans mon module :

    Sub CopyFolder(folderpath As String, destfolderpath As String)

    Dim fso As Object

    Dim fld As Object

        Set fso = CreateObject("Scripting.FileSystemObject")

        Set fld = fso.GetFolder(folderpath)

        fld.Copy destfolderpath

    End Sub

Pour mon bouton de commande :

Private Sub CommandButton1_Click()

Call CopyFolder("C:\Documents\ZZZZZZ Source", "C:\Documents\ZZZZZZ Destination")

End Sub

Mon souci, c'est que le collage se fait de façon intégrale, et je retrouve les sous-répertoires de mon répertoire source, dans mon répertoire de destination. Alors que je voudrais dans le répertoire destination ne trouver que les fichiers.

J'espère être assez claire dans mes explications, je vous joins une illustration en annexe, sachant que dans le logigramme, je ne fais apparaitre qu'un niveau de sous répertoire, alors qu'en fait j'ai dans les sous-répertoires, d'autres sous-répertoires.
Merci pour votre aide.
O.

 

[Staple1600]

Re

Je viens de refaire le test
Et cela fonctionne toujours

Je dois aussi avoir cela dans mes archives
(comment lancer un batch par VBA et/ ou comment lancer un batch par VBA (en masquant l'invite MSDOS)

Tu veux point publier,stp, ton bout de code que je le teste sur mon W10 ?

(moi aussi j'ai un coup de flemme: pas le temps de chercher dans mes archives )

 

[patricktoulon]

re

Sub test()
    originalPath = "H:\fond d'ecran"
    Destinationfolder = "C:\Users\polux\DeskTop\toto"
    batedebazball = "C:\Users\polux\DeskTop\batedebazball.cmd)"
    codebat = "@echo off" & vbCrLf
    codebat = codebat & "cls" & vbCrLf
    codebat = codebat & "Set allF = """ & originalPath & """" & vbCrLf
    codebat = codebat & "Set backup = """ & Destinationfolder & """" & vbCrLf
    codebat = codebat & "for /f ""tokens=*"" %%f in ('dir /b/s ""%allF%""') do copy /Y ""%%f"" ""%backup%""" & vbCrLf
    Debug.Print codebat
    
    'lance le fichier
    'x = FreeFile: Open batedebazball For Output As #x:Print #x, codebat:Close #x
    'Shell batedebazball
    
    'ou
    'lance la commande
    Shell ("C:\Windows\System32\cmd.exe /c " & codebat)

End Sub

 

[patricktoulon]

quand on met une pause au fichier créé
on vois bien qu'il liste le dossier document pas les dossiers en paramètre

Sub test()
    originalPath = "H:\fond d'ecran"
    Destinationfolder = "C:\Users\polux\DeskTop\toto"
    batedebazball = "C:\Users\polux\DeskTop\batedebazball.cmd"
    codebat = "@echo off" & vbCrLf
    codebat = codebat & "cls" & vbCrLf
    codebat = codebat & "Set allF = """ & originalPath & """" & vbCrLf
    codebat = codebat & "Set backup = """ & Destinationfolder & """" & vbCrLf
    codebat = codebat & "for /f ""tokens=*"" %%f in ('dir /b/s ""%allF%""') do copy /Y ""%%f"" ""%backup%""" & vbCrLf
    codebat = codebat & "pause" & vbCrLf
    Debug.Print codebat
    
    'lance le fichier
    x = FreeFile: Open batedebazball For Output As #x: Print #x, codebat: Close #x
    Shell "cmd.exe /c " & batedebazball
    
    'ou
    'lance la commande
    'Shell ("C:\Windows\System32\cmd.exe /c " & codebat)

End Sub

 

[Staple1600]

Re

patricktoulon
Fonctionne chez moi (mais avec un *.cmd crée manuellement)
CreateObject("WScript.Shell").Run "C:\Users\STAPLE1600\Documents\TestBckUp\copy.cmd"
Par contre ne fonctionne pas avec ton *.cmd créé par VBA.

 

[patricktoulon]

re
je vien d'essayer avec xcopy lancé par vba ca fonctionne sur même disque mais pas les deux de toute a l'heure
je vais modifier le nom pour être sur on aura la réponse comme ca
2 mn'

 

[patricktoulon]

bon j'ai trouvé les bon parametre avec xcopy

je confirme pour les accents et apostrophe ca plante je pense qu'il faut doubler les """
alors un truc étonnant lancer la commande est moins rapide que créer le bat et le lancer

Sub test()
   
    Dim x&, originalPath$, Destinationfolder$, batedebazball$
  
    'originalPath = "C:\Users\polux\DeskTop\toto1"
     originalPath = "H:\fond_d_ecran"
     Destinationfolder = "C:\Users\polux\DeskTop\toto"
    batedebazball = "C:\Users\polux\DeskTop\batedebazball.cmd"
    codebat = "xcopy " & originalPath & "  " & Destinationfolder & " /S /C /R /H /I /K /Y"
    Debug.Print codebat
   
    'lance le fichier
    'x = FreeFile: Open batedebazball For Output As #x: Print #x, codebat: Close #x
    'Shell "cmd.exe /c " & batedebazball 'ca fonctionne
    'Kill batedebazball
   
    'ou
   
    'lance la commande
    Shell ("C:\Windows\System32\cmd.exe /c " & codebat) 'fonctionne aussi (étonnant moins rapide que le fichier  cmd lancé

End Sub

EDIT:
par contre je n'arrive pas a copier les fichiers de sous dossier directement dans la destination sans structure de sous dossier

 

[Staple1600]

Re

Et cela n'explique pas pourquoi mon batch créé manuellement fonctionne
Mais que si on créé par VBA le même batch, il ne fonctionne pas
(Ni en cliquant dessus, ni en le lançant pas VBA)

 

[patricktoulon]

re
udf8

 

[patricktoulon]

re
chez moi même écrit a la main ca fonctionne pas en tout cas
puisque ca liste ce qui est dans les documents au lieu des dossiers écrits dans le code

xcopy par contre fonctionne
je vais chercher pour la destructuration de l'architecture dossier ce qui est la demande a la base
peut être avec dir% et faire de xcopy de fichiers
ca faisait longtemps que je ne m'etait pas amuser a ca

 

[Staple1600]

Re,

patricktoulon
Je testerai demain au boulot sur W7 Pro.

 

[Staple1600]

Re

Avec cette macro, test OK
(le fichier bat est créé et lancé par VBA et la copie se fait bien)

Sub Test_OK_W1064b_XL2013m()
Dim MSDcomm$, batF$, originalPath$, Destinationfolder$, FF As Byte
originalPath = "C:\Users\STAPLE1600\Documents\TestA"
Destinationfolder = "C:\Users\STAPLE1600\Documents\TestB"
batF = "C:\Users\STAPLE1600\Documents\TestB\copyALL.bat"
MSDcomm = _
"@echo off" & vbCrLf & "cls" & vbCrLf & "set allF=" & Chr(34) & originalPath & Chr(34) & vbCrLf & "set backup=" & Chr(34) _
& Destinationfolder & Chr(34) & vbCrLf & "for /f " & Chr(34) & "tokens=*" & Chr(34) & " %%f in ('dir /b/s " & Chr(34) _
& "%allF%" & Chr(34) & "') do copy /Y " & Chr(34) & "%%f" & Chr(34) & Space(1) & Chr(34) & "%backup%" & Chr(34)
FF = FreeFile
Open batF For Output As #FF
Print #FF, MSDcomm
Close #FF
CreateObject("WScript.Shell").Run batF, 1, True
DoEvents
End Sub

 

[Staple1600]

Bonsoir le fil,

"Les salopiauds!"
Au boulot, sur nos PC, l'invite MS-Dos est désactivée
Et donc je n'ai pas pu testé sur un W7
Si un XLDien avec W7 pouvait tester le batch MSDOS, ce serait chouette

Du coup, je suis reparti sur FSO (mais un chouia plus court)
Ca a l'air de fonctionner

Public strDest As String
Sub testCopie()
Dim strSRC$
'Ci-dessous adapter avec les vrais noms des chemins et noms de dossier
strSRC = "C:\Users\STAPLE1600\TestA": strDest = "C:\Users\STAPLE1600\TestB"
CopyAll strSRC
End Sub
Function CopyAll(rep)
Dim FSO As Object, objFdr, oDir, oFI, oFic
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objFdr = FSO.GetFolder(rep)
    If objFdr.SubFolders.Count <> 0 Then
      For Each oDir In objFdr.SubFolders
      CopyAll (oDir)
      Next
    End If
    Set oFic = objFdr.Files
    For Each oFI In oFic
      FSO.CopyFile oFI.Path, strDest & "\" & oFI.Name
    Next
End Function

PS: Quid des fichiers doublons dans N sous-répertoires que l'on recopie à la racine du dossier de recopie?
Windows devrait tousser, non ?

 

[patricktoulon]

re
Bonjour Staple1600
j'ai testé hier il fonctionne

et non il tousse pas il ajoute (x) aux noms pour les doublons
je ne sais plus si il y a un paramètre de copie écrasante
scripting étant largement moins rapide que dir et filecopy de vba je ne l'utilise quasiment plus
je regarderais dans mes anciens dossiers

et ajoute l'attribut dans ton model scripting ca evitera les erreurs et plantages pour certain dossiers system ou protégés
il est dans la page 1 mais je te le remet

Sub test()
    Dim racine$, Destinationfolder$
    originalPath = "H:\fond d'ecran\"
    Destinationfolder = "C:\Users\polux\DeskTop\toto"' le nouveau dossier est sur le bureau pour les tests
    liste = listeAndCopyfich_récursive(originalPath, Destinationfolder)
End Sub
'
'
Private Function listeAndCopyfich_récursive(originalPath, Optional newpath As String) As Variant
    Dim FSO As Object, Lparent As Object, SubFolder As Object, Fichier,fich$
    Set FSO = CreateObject("scripting.filesystemobject")    ' on declare l'object
    Set Lparent = FSO.GetFolder(originalPath)    'on attribue a l'object.getfolder le dossier demandé 'Scripting.Folder
  '************************************************************
If GetAttr(Lparent) <> 22 Then ' directory + vbnormal+vbreadonly+vbhidden et pas vbsystem
'*************************************************************
       For Each Fichier In Lparent.Files    'on boucle sur les fichiers qui sont dans ce dossier
            fich = Mid(Fichier, InStrRev(Fichier, "\") + 1) 'recup le nom dans le chemin
            Fichier.Copy newpath & "\" & fich
            Next
        'boucles sur les sous dossiers
        For Each SubFolder In Lparent.SubFolders    'on boucle sur les dossiers qui sont dans ce dossiers
             listeAndCopyfich_récursive SubFolder.Path, newpath    'si sub sub dossiers on rappelle la fonction en interne (récursivité)
        Next SubFolder
    End If
End Function

EDIT:
Ps:
pour le bat il faut quand même trouver la bonne formulation pour le lancer sans passer par un fichier intermédiaire ça serait plus classe
je l'ai testé comme tel et ça ne fonctionne pas en directe
je pense qu'il y a encore une histoire de guillemets a doubler