Copier tous les fichiers xls d'un sous répertoire

joel31

XLDnaute Junior
Bonjour à tous,

Je bute sur une action dont je n'arrive pas à trouver la solution.
Je souhaite copier tous les fichiers xls du sous répertoire d'un dossier vers un autre emplacement.

voici en gros l'architecture :

E:\RELEVE HEBERGEMENT\ puis sous dossier TOTO, TATA, TITI etc.. et dans chaque sous dossier un fichier xls.

Je souhaite donc copier tous les fichiers xls vers un autre emplacement : C:CATHERINE\RH

J'ai actuellement la macro suivante :

Sub import()
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists("E:\RELEVE HEBERGEMENT\") Then
FSO.CopyFolder "E:\RELEVE HEBERGEMENT", "C:\CATHERINE\RH"
End If
End Sub


Mais cette macro m'importe l'ensemble du dossier et non que les fichiers xls.

Comment donc modifier la macro pour n'importer que les fichiers xls dans C:\CATHERINE\RH

Merci pour votre aide

Bien cordialement
Joël
 

Staple1600

XLDnaute Barbatruc
Re : Copier tous les fichiers xls d'un sous répertoire

Bonsoir à tous

joel31
Tu as essayé de voir ce que pourrait donner robocopy ?
(en passant par l'invite de commande)
Lances robocopy /? pour avoir les différents paramètres
puis crées le batch adéquat (*.bat ou *.cmd)

Ou puisque tu connais déjà Windows Scripting Host, tu devrais trouver sur le net des exemples pouvant t'aider.
EDITION: Voir ce script (par exemple)
http://vlaurie.com/computers2/downloads/copy_files_with_ext2.zip
(Il faudra bien sur l'adapter à ton cas et en l'état c'est un script VBS)
Mais il peut-être modifier pour le lancer à partir d'Excel
(enfin j'espère car je n'ai pas oouvert le zip,mais je suis confiant sur ce coup là ;)

Tu peux aussi le faire tout en VBA only ;)
(voir dans les archives du forum dans ce cas)

Tu peux aussi passer par la recherche Windows (en cherchant *.xls et en spécifiant le répertoire racine adéquat)
Puis tu fais CTRL+A puis CTRL+C et enfin CTRL+V
 
Dernière édition:

Toine45

XLDnaute Junior

Toine45

XLDnaute Junior
Re : Copier tous les fichiers xls d'un sous répertoire

Re
Une autre piste, peut-être dont tu peux éventuellement t'inspirer (Réponse N°3 du post), dans laquel, il me semble qu'en mettant l'option "False" (voir ci-dessous), les sous répertoires ne sont pas copiés, si j'ai bien compri la macro
'Inclure les sous-répertoires dans la liste, True or False
SousRep = True

Copier fichiers dans un répertoire - Microsoft Community

Bonne soirée
 

joel31

XLDnaute Junior
Re : Copier tous les fichiers xls d'un sous répertoire

Bonsoir Staple, Toine, le fil,

Je vous remercie pour votre aide précieuse, et j'ai retenu la solution de Toine qui fonctionne très bien ;

Bonne soirée
Cordialement
 

joel31

XLDnaute Junior
Re : Copier tous les fichiers xls d'un sous répertoire

Bonsoir Staple1600,


(Tu avais regardé le zip, celui du lien cité dans mon message?)
Quand j'ai dézippé le fichier, il m'a planté l'ordi, surement une mauvaise manip de ma part, alors je n'ai pas trop insisté !!!
Mais comme tu dis j'ai trouvé une fois de plus mon bonheur sur ce beau forum

Bonne soirée.

Bien cordialement
 

Staple1600

XLDnaute Barbatruc
Re : Copier tous les fichiers xls d'un sous répertoire

Re

Par acquis de conscience, j'ai été voir ce qu'il y avait dans le zip.
C'est un script vbs (fichier avec extension *.vbs)
Si tu veux voir ce qu'il contient sans souci, renommes-le en *.txt et ouvres le dans le bloc-notes.
Enfin c'est peut-être pas utile désormais vu que le script de MichD (c'est l'auteur du code dans le lien cité par Toine45) est beaucoup plus simple et concis.

En plus le script dans le zip est en anglais, ce qui est moins pratique si tu n'es pas anglophone.

Mais au moins, c'est toujours bon à prendre pour nourrir sa curiosité ;)
 

Toine45

XLDnaute Junior
Re : Copier tous les fichiers xls d'un sous répertoire

Bonjour
Pour une utilisation plus pratique, j'ai modifié la macro en y ajoutant un choix des dossiers par boîtes de dialogue.
(Pensez à modifier les chemins par defaut avec votre nom)

Code:
'Déclaration des variables dans le haut du module
Option Explicit
Dim Obj As Object
Dim Arr()
Sub A_CopieDesFichiers_Répertoires_Et_Sous_Répertoires()
'Copie les Fichiers d'un Répertoire et de ses Sous Répertoires
Dim RépertoireSource As String, Lextension As Variant
Dim Ok As Boolean, RépertoireDestination As String
Dim SousRep As Boolean

' Choix par boîte de dialogue
Dim DossierA As FileDialog
Dim DossierB As FileDialog

    Set DossierA = Application.FileDialog(msoFileDialogFolderPicker)
    Set DossierB = Application.FileDialog(msoFileDialogFolderPicker)
      
     With DossierA
          .AllowMultiSelect = False
          .InitialFileName = "C:\Users\Nom_du_propriétaire_du_compte\Documents\" 'A adapter le chemin
          .Title = "Choix du dossier source"
          If .Show = -1 Then RépertoireSource = .SelectedItems(1) & "\" Else RépertoireSource = 0
     End With
     
     With DossierB
          .AllowMultiSelect = False
          .InitialFileName = "C:\Users\Nom_du_propriétaire_du_compte\Documents\"  'A adapter le chemin
          .Title = "Choix du dossier destination"
          If .Show = -1 Then RépertoireDestination = .SelectedItems(1) & "\" Else RépertoireDestination = 0
     End With

'********** À adapter éventuellement en cas de non utilisation de boîte de dialogue *****************
        'Définir le répertoire Source
'RépertoireSource = "c:\Users\MonNom\Documents\Départ\"
        'Définir le répertoire Source
'RépertoireDestination = "c:\Users\MonNom\Documents\Destination\"
'************************************************
                'À adapter pour la copie :
        'Inclure les fichiers des sous-répertoires : "True"
        'exclure les fichiers des sous-répertoires : "False"
SousRep = True
'************************************************
If Dir(RépertoireSource, vbDirectory) = "" Then
    MsgBox "Le répertoire source : """ & RépertoireSource & _
        """ est introuvable. Opération annulée."
    Exit Sub
End If
If Dir(RépertoireDestination, vbDirectory) = "" Then
    MsgBox "Le Répertoire de destination : """ & RépertoireDestination & _
        """ est introuvable. Opération annulée."
    Exit Sub
End If
Ok = False
Do
    'Selon les besoins, on peut définir les catégories à
    'afficher et les extensions pour chaque type.
    Lextension = Application.InputBox( _
        "1- Classeurs Excel                 |          6 = Tous les fichiers" & vbCrLf & _
        "2- Documents Word" & vbCrLf & _
        "3- Fichiers de musique" & vbCrLf & _
        "4- Fichiers texte" & vbCrLf & _
        "5- Présentations PowerPoint" & vbCrLf & _
        "Insérer LE numéro correspondant.", "Type de fichier à afficher?")
    If Val(Lextension) > 0 And Val(Lextension) < 7 Then
        Ok = True
        Select Case Val(Lextension)
            Case Is = 1 'Fichiers Excel
                Arr = Array(".xls", ".xlt", ".xlsx", _
                    ".xlsm", ".xla", ".xlam", ".xlb")
            Case Is = 2 'Fichiers Word
                Arr = Array(".doc", ".dot", ".docx", _
                        ".docm", ".dotm", ".dotx")
            Case Is = 3 ' Fichiers de musique
                Arr = Array(".mp3", ".wav", ".flac")
            Case Is = 4 'Fichiers Texte
                Arr = Array(".txt", ".csv", ".rtf")
            Case Is = 5 'Fichiers PowerPoint
                Arr = Array(".ppt", ".pps", ".ppsx", ".ppsm")
            Case Is = 6 'Tous les fichiers
                Arr = Array("tous")
        End Select
    Else
        If MsgBox("Votre choix est autre que ceux suggérés." & vbCrLf & _
            vbCrLf & "désirez-vous annuler l'opération?", _
                vbCritical + vbYesNo, "Attention") = vbYes Then
            Exit Sub
        End If
    End If
Loop Until Ok = True
Set Obj = CreateObject("Scripting.FileSystemObject")
Call CopieDeFichiers(RépertoireSource, RépertoireDestination, SousRep)
End Sub
'-----------------------------------------
Sub CopieDeFichiers(RépertoireSource As String, _
                RépertoireDestination As String, _
                Inclure_Sous_Répertoires As Boolean)
Dim RepSource As Object, F As Object
Dim SousRepSource As Object, Ext As String
Set RepSource = Obj.getfolder(RépertoireSource)
For Each F In RepSource.Files
    Ext = "." & Split(F.Name, ".")(UBound(Split(F.Name, ".")))
    If Not IsError(Application.Match(Ext, Arr, 0)) Or Arr(0) = "tous" Then
        Obj.CopyFile RepSource.Path & "\" & F.Name, RépertoireDestination, True
    End If
Next
If Inclure_Sous_Répertoires Then
    For Each SousRepSource In RepSource.SubFolders
        Call CopieDeFichiers(SousRepSource.Path, RépertoireDestination, True)
    Next
End If
End Sub
Bonne journée
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas