Copier fichier word des sous répertoires d'un dossier vers un dossier

Bonjour,

Voilà mon problème, j'essaye de copier des fichiers en .docx contenus dans des sous répertoires vers un dossier.

Voici mon code :

Dim fso As Object
Dim Src$, Dest$, Destination As String

Set fso = CreateObject("Scripting.FileSystemObject")

Src = Textbox1.Value & "\*.docx"
Dest = TextBox2.Value & "\"

fso.CopyFile Src, Dest

Comment dire à VBA d'aller regarder dans les sous répertoires à partir du chemin indiqué où se trouvent l'ensemble des sous dossiers et de copier les fichiers word ?

Merci d'avance

GuiGui8731

Bonjour Guigui,

Voici un premier essai (pour l'instant sans fso) de code pour ton problème, si je l'ai compris :

Sub test()

Dim Src$, Dest$, strCurrentFile$
Dim arrSubFoldersSrc

Src = textbox1.value & "\"
Dest = textbox2.value & "\"

'TABLEAU CONTENANT LES SOUS-DOSSIERS
arrSubFoldersSrc = ListeDossiers(Src)

'PARCOURT CHAQUE FICHIER DE CHAQUE REP SOURCE ET COPIE DANS REP DESTINATION
For i = LBound(arrSubFoldersSrc) To UBound(arrSubFoldersSrc)
    strCurrentFile = Dir(arrSubFoldersSrc(i) & "*.docx")
    While strCurrentFile <> ""
        FileCopy arrSubFoldersSrc(i) & strCurrentFile, Dest & strCurrentFile
        strCurrentFile = Dir
    Wend
Next i

End Sub

Function ListeDossiers(strRepertoire$)

Dim strDossier$, n&, temp()

strDossier = Dir(strRepertoire, vbDirectory)
While strDossier <> ""
    If Not strDossier Like "*.*" Then
        ReDim Preserve temp(n)
        temp(n) = strRepertoire & strDossier & "\"
        n = n + 1
    End If
    strDossier = Dir
Wend
ListeDossiers = temp

End Function

Ici, il n'y a pas de contrôle préalable de l'exsitence des 2 répertoires renseignés sur les textbox (donc ils sont considérés créés). On stocke l'ensemble des répertoires des sous-dossiers dans un tableau puis on parcourt, pour chaque sous-dossier, tous les fichiers ".docx". On les copie tous dans le même dossier de destination.

A tester...

Cdlt,

Bonjour 3GB,

Merci pour ton retour.

Je viens de tester ton code et la macro bloque sur les déclarations pour les textbox en me disant "Objet requis".

Est-ce le fait que les variables Src et Dest soit déclarées différemment ?

Ou est-ce que ce sont mes textbox qui posent problème ?

GuiGui8731

Ce sont les textbox. En fait, tu dois ajouter le nom de l'userform devant :

src = MonUF.textbox1.value

A priori ça ira ensuite si ces textbox existent bien sous ces 2 noms.

Mais il n'est pas impossible qu'il y ait d'autres petits pépins...

Bonjour 3GB,

Alors en rajoutant le nom de l'userform devant les textbox le problème n'apparaît plus.

En revanche maintenant j'ai une erreur sur la ligne : For i , indiquant une incompatibilité de type.

Est-ce normal ?

GuiGui8731

Peux-tu essayer avec ce nouveau code :

Sub test()

Dim Src$, Dest$, strCurrentFile$
Dim arrSubFoldersSrc

if dir(Userform1.textbox1.value, vbdirectory) = "" then msgbox "Source inexistante", vbcritical: exit sub
if dir(Userform1.textbox2.value, vbdirectory) = "" then msgbox "Destination inexistante", vbcritical: exit sub

Src = Userform1.textbox1.value & "\"
Dest = Userform1.textbox2.value & "\"

'TABLEAU CONTENANT LES SOUS-DOSSIERS
arrSubFoldersSrc = ListeDossiers(Src)

'PARCOURT CHAQUE FICHIER DE CHAQUE REP SOURCE ET COPIE DANS REP DESTINATION
For i = LBound(arrSubFoldersSrc) To UBound(arrSubFoldersSrc)
    strCurrentFile = Dir(arrSubFoldersSrc(i) & "*.docx")
    While strCurrentFile <> ""
        FileCopy arrSubFoldersSrc(i) & strCurrentFile, Dest & strCurrentFile
        strCurrentFile = Dir
    Wend
Next i

End Sub

Function ListeDossiers(strRepertoire$)

Dim strDossier$, n&, temp()

strDossier = Dir(strRepertoire, vbDirectory)
While strDossier <> ""
    If Not strDossier Like "*.*" Then
        ReDim Preserve temp(n)
        temp(n) = strRepertoire & strDossier & "\"
        n = n + 1
    End If
    strDossier = Dir
Wend
ListeDossiers = temp

End Function

A priori le problème ne vient pas du fichier. Qu'y avait-il dans tes textbox ? Cette fois on teste l'existence. Il faut que les dossiers existent et contiennent des dossiers...

Pour les essais, tu peux dans un premier temps mettre les chemins en dur...

Il faudra peut-être adapter le nom de l'userform que j'ai rajouté cette fois-ci

Cdlt,

Bonjour 3GB,

Avec la modification de ton code ça marche parfaitement.

Merci beaucoup pour ton aide.

GuiGui8731

Houra !

Merci pour ton retour !

Très bonne soirée et à bientôt peut-être,