Copier des classeurs en fonction du nom vers un autre répertoire
1 réponse
david anceau
Bonjour =E0 tous,
Je dois copier des classeurs dont le nom contient un mot d=E9fini dans
un autre classeur (portant le nom d=E9fini et =E0 cr=E9=E9r si inexistant)
Exemple : c:\Collections - 06_02_2009\Amiens\Amiens-Stone Fashion
H09.xls vers le dossier c:\Stone Fashion.
La contrainte est le caract=E8re r=E9cursif des dossiers et la copie en
fonction du nom.
J'ai trouv=E9 une macro avec connexion ADO qui liste les fichiers
contenus dans des dossiers et des sous-dossiers, mais je ne voit pas
comment intercaler avec un FileCopy en fonction du nom ...
Pouvez vous m'aider ?
Merci d'avance
Voici le code de la macro ADO :
Option Explicit
Sub TestListeFichiers()
Dim Dossier As String
'D=E9finit le r=E9pertoire pour d=E9buter la recherche de fichiers.
'(Attention =E0 ne pas indiquer un r=E9pertoire qu contient trop de
sous-dossiers ou de
'fichiers, sinon le temps de traitement va =EAtre tr=E8s long).
Dossier =3D "c:\Collections - 06_02_2009"
'Appelle la proc=E9dure de recherche des fichiers
ListeFichiers Dossier
'Ajuste la largeur des colonnes A:E en fonction du contenu des
cellules.
Columns("A:E").AutoFit
MsgBox "Termin=E9"
End Sub
Sub ListeFichiers(Repertoire As String)
'
'N=E9cessite d'activer la r=E9f=E9rence "Microsoft Scripting RunTime"
'Dans l'=E9diteur de macros (Alt+F11):
'Menu Outils
'R=E9f=E9rences
'Cochez la ligne "Microsoft Scripting RunTime".
'Cliquez sur le bouton OK pour valider.
Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim i As Long
Set Fso =3D CreateObject("Scripting.FileSystemObject")
Set SourceFolder =3D Fso.GetFolder(Repertoire)
'R=E9cup=E8re le num=E9ro de la derni=E8re ligne vide dans la colonne A=
.
i =3D Range("A65536").End(xlUp).Row + 1
'Boucle sur tous les fichiers du r=E9pertoire
For Each FileItem In SourceFolder.Files
'Inscrit le nom du fichier dans la cellule
Cells(i, 1) =3D FileItem.Name
'Ajoute un lien hypertexte vers le fichier
ActiveSheet.Hyperlinks.Add Anchor:=3DCells(i, 1), _
Address:=3DFileItem.ParentFolder & "\" & FileItem.Name
'Indique la date de cr=E9ation
Cells(i, 2) =3D FileItem.DateCreated
'Indique la date de dernier acces
Cells(i, 3) =3D FileItem.DateLastAccessed
'Indique la date de derni=E8re modification
Cells(i, 4) =3D FileItem.DateLastModified
'Nom du r=E9pertoire
Cells(i, 5) =3D FileItem.ParentFolder
i =3D i + 1
Next FileItem
'--- Appel r=E9cursif pour lister les fichier dans les sous-
r=E9pertoires ---.
For Each SubFolder In SourceFolder.subfolders
ListeFichiers SubFolder.Path
Next SubFolder
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Daniel.C
Bonjour.
Sub RechercheFichiers() 'Credit JB racine = "e:donneesdanielmpfe" Set fso = CreateObject("Scripting.FileSystemObject") Set dossier_racine = fso.getfolder(racine) Lit_dossier dossier_racine End Sub Sub Lit_dossier(ByRef dossier) For Each d In dossier.SubFolders Lit_dossier d Next For Each f In dossier.Files If Mid(f.Name, 1, 2) = "09" Then FileCopy f.Path, "c:temp" & f.Name End If Next End Sub
Cordialement. Daniel
Bonjour à tous,
Je dois copier des classeurs dont le nom contient un mot défini dans un autre classeur (portant le nom défini et à créér si inexistant) Exemple : c:Collections - 06_02_2009AmiensAmiens-Stone Fashion H09.xls vers le dossier c:Stone Fashion.
La contrainte est le caractère récursif des dossiers et la copie en fonction du nom.
J'ai trouvé une macro avec connexion ADO qui liste les fichiers contenus dans des dossiers et des sous-dossiers, mais je ne voit pas comment intercaler avec un FileCopy en fonction du nom ...
Pouvez vous m'aider ? Merci d'avance
Voici le code de la macro ADO :
Option Explicit
Sub TestListeFichiers() Dim Dossier As String
'Définit le répertoire pour débuter la recherche de fichiers. '(Attention à ne pas indiquer un répertoire qu contient trop de sous-dossiers ou de 'fichiers, sinon le temps de traitement va être très long). Dossier = "c:Collections - 06_02_2009"
'Appelle la procédure de recherche des fichiers ListeFichiers Dossier
'Ajuste la largeur des colonnes A:E en fonction du contenu des cellules. Columns("A:E").AutoFit MsgBox "Terminé" End Sub
Sub ListeFichiers(Repertoire As String) ' 'Nécessite d'activer la référence "Microsoft Scripting RunTime" 'Dans l'éditeur de macros (Alt+F11): 'Menu Outils 'Références 'Cochez la ligne "Microsoft Scripting RunTime". 'Cliquez sur le bouton OK pour valider.
Dim Fso As Scripting.FileSystemObject Dim SourceFolder As Scripting.Folder Dim SubFolder As Scripting.Folder Dim FileItem As Scripting.File Dim i As Long
Set Fso = CreateObject("Scripting.FileSystemObject") Set SourceFolder = Fso.GetFolder(Repertoire)
'Récupère le numéro de la dernière ligne vide dans la colonne A. i = Range("A65536").End(xlUp).Row + 1
'Boucle sur tous les fichiers du répertoire For Each FileItem In SourceFolder.Files 'Inscrit le nom du fichier dans la cellule Cells(i, 1) = FileItem.Name 'Ajoute un lien hypertexte vers le fichier ActiveSheet.Hyperlinks.Add Anchor:Îlls(i, 1), _ Address:=FileItem.ParentFolder & "" & FileItem.Name 'Indique la date de création Cells(i, 2) = FileItem.DateCreated 'Indique la date de dernier acces Cells(i, 3) = FileItem.DateLastAccessed 'Indique la date de dernière modification Cells(i, 4) = FileItem.DateLastModified 'Nom du répertoire Cells(i, 5) = FileItem.ParentFolder
i = i + 1 Next FileItem
'--- Appel récursif pour lister les fichier dans les sous- répertoires ---. For Each SubFolder In SourceFolder.subfolders ListeFichiers SubFolder.Path Next SubFolder
End Sub
Bonjour.
Sub RechercheFichiers()
'Credit JB
racine = "e:donneesdanielmpfe"
Set fso = CreateObject("Scripting.FileSystemObject")
Set dossier_racine = fso.getfolder(racine)
Lit_dossier dossier_racine
End Sub
Sub Lit_dossier(ByRef dossier)
For Each d In dossier.SubFolders
Lit_dossier d
Next
For Each f In dossier.Files
If Mid(f.Name, 1, 2) = "09" Then
FileCopy f.Path, "c:temp" & f.Name
End If
Next
End Sub
Cordialement.
Daniel
Bonjour à tous,
Je dois copier des classeurs dont le nom contient un mot défini dans
un autre classeur (portant le nom défini et à créér si inexistant)
Exemple : c:Collections - 06_02_2009AmiensAmiens-Stone Fashion
H09.xls vers le dossier c:Stone Fashion.
La contrainte est le caractère récursif des dossiers et la copie en
fonction du nom.
J'ai trouvé une macro avec connexion ADO qui liste les fichiers
contenus dans des dossiers et des sous-dossiers, mais je ne voit pas
comment intercaler avec un FileCopy en fonction du nom ...
Pouvez vous m'aider ?
Merci d'avance
Voici le code de la macro ADO :
Option Explicit
Sub TestListeFichiers()
Dim Dossier As String
'Définit le répertoire pour débuter la recherche de fichiers.
'(Attention à ne pas indiquer un répertoire qu contient trop de
sous-dossiers ou de
'fichiers, sinon le temps de traitement va être très long).
Dossier = "c:Collections - 06_02_2009"
'Appelle la procédure de recherche des fichiers
ListeFichiers Dossier
'Ajuste la largeur des colonnes A:E en fonction du contenu des
cellules.
Columns("A:E").AutoFit
MsgBox "Terminé"
End Sub
Sub ListeFichiers(Repertoire As String)
'
'Nécessite d'activer la référence "Microsoft Scripting RunTime"
'Dans l'éditeur de macros (Alt+F11):
'Menu Outils
'Références
'Cochez la ligne "Microsoft Scripting RunTime".
'Cliquez sur le bouton OK pour valider.
Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim i As Long
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(Repertoire)
'Récupère le numéro de la dernière ligne vide dans la colonne A.
i = Range("A65536").End(xlUp).Row + 1
'Boucle sur tous les fichiers du répertoire
For Each FileItem In SourceFolder.Files
'Inscrit le nom du fichier dans la cellule
Cells(i, 1) = FileItem.Name
'Ajoute un lien hypertexte vers le fichier
ActiveSheet.Hyperlinks.Add Anchor:Îlls(i, 1), _
Address:=FileItem.ParentFolder & "" & FileItem.Name
'Indique la date de création
Cells(i, 2) = FileItem.DateCreated
'Indique la date de dernier acces
Cells(i, 3) = FileItem.DateLastAccessed
'Indique la date de dernière modification
Cells(i, 4) = FileItem.DateLastModified
'Nom du répertoire
Cells(i, 5) = FileItem.ParentFolder
i = i + 1
Next FileItem
'--- Appel récursif pour lister les fichier dans les sous-
répertoires ---.
For Each SubFolder In SourceFolder.subfolders
ListeFichiers SubFolder.Path
Next SubFolder
Sub RechercheFichiers() 'Credit JB racine = "e:donneesdanielmpfe" Set fso = CreateObject("Scripting.FileSystemObject") Set dossier_racine = fso.getfolder(racine) Lit_dossier dossier_racine End Sub Sub Lit_dossier(ByRef dossier) For Each d In dossier.SubFolders Lit_dossier d Next For Each f In dossier.Files If Mid(f.Name, 1, 2) = "09" Then FileCopy f.Path, "c:temp" & f.Name End If Next End Sub
Cordialement. Daniel
Bonjour à tous,
Je dois copier des classeurs dont le nom contient un mot défini dans un autre classeur (portant le nom défini et à créér si inexistant) Exemple : c:Collections - 06_02_2009AmiensAmiens-Stone Fashion H09.xls vers le dossier c:Stone Fashion.
La contrainte est le caractère récursif des dossiers et la copie en fonction du nom.
J'ai trouvé une macro avec connexion ADO qui liste les fichiers contenus dans des dossiers et des sous-dossiers, mais je ne voit pas comment intercaler avec un FileCopy en fonction du nom ...
Pouvez vous m'aider ? Merci d'avance
Voici le code de la macro ADO :
Option Explicit
Sub TestListeFichiers() Dim Dossier As String
'Définit le répertoire pour débuter la recherche de fichiers. '(Attention à ne pas indiquer un répertoire qu contient trop de sous-dossiers ou de 'fichiers, sinon le temps de traitement va être très long). Dossier = "c:Collections - 06_02_2009"
'Appelle la procédure de recherche des fichiers ListeFichiers Dossier
'Ajuste la largeur des colonnes A:E en fonction du contenu des cellules. Columns("A:E").AutoFit MsgBox "Terminé" End Sub
Sub ListeFichiers(Repertoire As String) ' 'Nécessite d'activer la référence "Microsoft Scripting RunTime" 'Dans l'éditeur de macros (Alt+F11): 'Menu Outils 'Références 'Cochez la ligne "Microsoft Scripting RunTime". 'Cliquez sur le bouton OK pour valider.
Dim Fso As Scripting.FileSystemObject Dim SourceFolder As Scripting.Folder Dim SubFolder As Scripting.Folder Dim FileItem As Scripting.File Dim i As Long
Set Fso = CreateObject("Scripting.FileSystemObject") Set SourceFolder = Fso.GetFolder(Repertoire)
'Récupère le numéro de la dernière ligne vide dans la colonne A. i = Range("A65536").End(xlUp).Row + 1
'Boucle sur tous les fichiers du répertoire For Each FileItem In SourceFolder.Files 'Inscrit le nom du fichier dans la cellule Cells(i, 1) = FileItem.Name 'Ajoute un lien hypertexte vers le fichier ActiveSheet.Hyperlinks.Add Anchor:Îlls(i, 1), _ Address:=FileItem.ParentFolder & "" & FileItem.Name 'Indique la date de création Cells(i, 2) = FileItem.DateCreated 'Indique la date de dernier acces Cells(i, 3) = FileItem.DateLastAccessed 'Indique la date de dernière modification Cells(i, 4) = FileItem.DateLastModified 'Nom du répertoire Cells(i, 5) = FileItem.ParentFolder
i = i + 1 Next FileItem
'--- Appel récursif pour lister les fichier dans les sous- répertoires ---. For Each SubFolder In SourceFolder.subfolders ListeFichiers SubFolder.Path Next SubFolder