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.

 

[patricktoulon]

re
Bonjour
il te faut boucler sur les subfolders de fld avec for each
et en plus recursif histoire d’être tranquille avec les subsubsubsub....folder

 

[Staple1600]

Bonjour le fil,

ou utiliser Powershell
(et si besoin Powershell depuis Excel)

 

[patricktoulon]

re
sinon adapté de mon listeur recursif FSO

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
        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

j'ai la même chose avec dir en récursif si tu veux

 

[océanne]

Bonjour JM et Patrick et merci pour votre attention.

JM, je ne connais pas PowerShell. Patrick, pourrais-tu stp me communiquer un exemple afin que je parvienne à imbriquer le for each pour les "subfolder"

d'avance merci
O.

 

[patricktoulon]

re
c'est fait

 

[Staple1600]

Re

Alors à défaut de powershell, un bon vieux batch MS-DOS
Ouvrir le bloc-notes et copier ce qui suit
(en prenant soin de changer le chemin des dossiers)

@echo off
cls
set allF="C:\Users\STAPLE1600\Documents\TestA"
set backup="C:\Users\STAPLE1600\Documents\TestBckUp"
for /f "tokens=*" %%f in ('dir /b/s "%allF%"') do copy /Y "%%f" "%backup%"

Ensuite enregistrer sur le bureau avec comme nom copie.bat ou copie.cmd

NB: Il faut que dans les options d’affichage de Windows, les extensions de fichiers soient visibles
(Pour ce faire, décocher : Masquer les extensions de fichiers...)

PS: Je viens de faire le test sur W10
Ça marche bien (et cela rappelle le bon vieux temps de W98SE

 

[océanne]

Merci à vous deux, je vais investiguer avec vos deux propositions.
O.

 

[océanne]

C'est tout bon, merci encore pour votre aide et pour la diversité de vos réponses.
O.

 

[Staple1600]

Re

océanne
Qu'est-ce qui est tout bon?
Quelle solution as-tu privilégiée?
le fichier batch ou le code VBA?
Et si c'est le code VBA, tu peux le publier, ici peut-être ?
Il pourrait resservir à d'autres confrontés à une problématique identique à la tienne

 

[patricktoulon]

Staple1600 j'ai essayé ton bat avant de le lancer par vba directement sur le bureau et ca ne fonctionne pas W7

@echo off
cls
Set allF = "H:\fond d'ecran"
Set backup = "C:\Users\polux\DeskTop\toto"
for /f "tokens=*" %%f in ('dir /b/s "%allF%"') do copy /Y "%%f" "%backup%"

 

[Staple1600]

Re

Chez moi W10, cela fonctionne
La seule différence c'est que pour mon test , mes dossiers étaient tous les deux dans Documents (et donc sur le même lecteur C)

 

[patricktoulon]

re
essaie avec un nom composé voir avec des apostrophes ou accents pour voir si ca fonctionne toujours

 

[Staple1600]

Re

Ch'uis habitué au noms format 8.3 (depuis W3.11)
Donc mes noms de dossiers ont rarement des noms chelous

Mais on doit pouvoir peaufiner la chose
(ou finir par sortir un script powershell )

 

[patricktoulon]

re bon je viens de tester sur meme disque avec nom simple et ca ne fonctionne pas
j'ai ajouté une pause pour relire le compte rendu et 0 fichiers copiés

@echo off
cls
Set allF = "C:\Users\polux\DeskTop\toto1"
Set backup = "C:\Users\polux\DeskTop\toto"
for /f "tokens=*" %%f in ('dir /b/s "%allF%"') do copy /Y "%%f" "%backup%"
pause

c'est dommage j'ai le code pour la lancer par vba sans passer par fichier intermédiaire