Copier tous les fichiers xls de sous dossiers dont le noms ne me sont pas connus FSO

Bonjour,

Tu peux utiliser ceci :
La procédure copie tous les fichiers Excel et les sous-répertoires
avec leurs fichiers Excel du répertoire source.


'------------------------------------------
Sub test()
Dim Source As String
Dim destination As String

'*****VARIABLES À DÉFINIR*********
Source = "c:MichD*.xl*"
destination = "c:Excel"
'**********************************

commande = Environ$("comspec") & " /c xcopy """ & _
Source & """ """ & destination & """ " & "/s/e"
Shell commande, 0
End Sub
'------------------------------------------


MichD
--------------------------------------------
"Bidou" a écrit dans le message de groupe de discussion : 4d7cb132$0$32436$ba4acef3@reader.news.orange.fr...

Bonjour,

Je souhaiterais copier tous les fichiers à extension xls se trouvant dans
des sous dossiers ( dont les noms sont variables) d'un lecteur E vers un
dossier TEMP se trouvant sous mon répertoire C
avec FSO et le code suivant tous les fichiers sous dossiers et dossier sont
copiés mais je ne voudrais copier que les classeurs

Dim fso As Object

Set fso = CreateObject("scripting.filesystemobject")
fso.CopyFolder "E:TOTO SOUS-DOSSIER1 classeur1.xls, classeur2.xls
SOUS-DOSSIER2classeur3.xls, classeur4.xls SOUS-DOSSIER3classeur5.xls,
classeur6.xls", "C:TEMP"

MsgBox " les fichiers Excel ont été transférés sur votre micro"

Merci de votre aide

bonjour Bidou,

Sub test()
Dim Fich As String, Chemin As String
Dim Dossier As Object, sf
Chemin = "E:"
Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.getfolder(Chemin)

For Each sf In Dossier.SubFolders
For Each f In sf.Files
If Right(f.Name, 4) = ".xls" Then
Set MyFile = fso.GetFile(f.Path)
MyFile.Copy ("C:TEMP")
End If
Next
Next
End Sub

isabelle


Le 2011-03-13 07:57, Bidou a écrit :

Bonjour,

Je souhaiterais copier tous les fichiers à extension xls se trouvant dans
des sous dossiers ( dont les noms sont variables) d'un lecteur E vers un
dossier TEMP se trouvant sous mon répertoire C
avec FSO et le code suivant tous les fichiers sous dossiers et dossier sont
copiés mais je ne voudrais copier que les classeurs

Dim fso As Object

Set fso = CreateObject("scripting.filesystemobject")
fso.CopyFolder "E:TOTO SOUS-DOSSIER1 classeur1.xls, classeur2.xls
SOUS-DOSSIER2classeur3.xls, classeur4.xls SOUS-DOSSIER3classeur5.xls,
classeur6.xls", "C:TEMP"

MsgBox " les fichiers Excel ont été transférés sur votre micro"

Merci de votre aide

Si tu veux copier tous les fichiers Excel des répertoires et sous-répertoires
dans le même répertoire de destination :
Tu n'as qu'à définir les variables.

'----------------------------------------------------
'Déclaration des variables dans le haut du module
Dim FSO As Object
Dim myBaseFolder As Object
Dim myFolder As Object
Dim F As Object

'----------------------------------------------------
Sub FoldersList()
Dim répertoireSource As String
Dim RépertoireDestination As String

'********Définir les variables***********
répertoireSource = "c:denis"
RépertoireDestination = "c:denis1"
'Ne pas oublier le ""
'****************************************

Set FSO = CreateObject("scripting.filesystemobject")
On Error Resume Next
Call FoldersInFolder(répertoireSource, RépertoireDestination)
End Sub

Sub FoldersInFolder(myFolderName As String, Dest As String)
Set myBaseFolder = FSO.getfolder(myFolderName)
For Each F In myBaseFolder.Files
If F.Name Like "*.xl*" Then
F.Copy Dest & F.Name
End If
Next
For Each myFolder In myBaseFolder.SubFolders
Call FoldersInFolder(myFolder.Path, Dest)
Next
End Sub
'----------------------------------------------------



MichD
--------------------------------------------

À titre de complément,

Cette approche reproduit la même structure hiérarchique des répertoires dans
le répertoire de destination, mais ne copiera que les fichiers Excel.

'------------------------------------------
Sub test()
Dim Source As String
Dim destination As String

'*****VARIABLES À DÉFINIR*********
Source = "c:MichD*.xl*"
destination = "c:Excel"
'**********************************

commande = Environ$("comspec") & " /c xcopy """ & _
Source & """ """ & destination & """ " & "/s/e"
Shell commande, 0
End Sub
'------------------------------------------

Une autre approche qui insère un API de Windows. Cette procédure permet de
copier tous les fichiers Excel du répertoire défini et de ses sous-répertoires.
Contrairement aux 2 autres procédures, elle permet de choisir si l'on désire
écraser ou non un fichier déjà existant dans le répertoire de destination.
De plus, elle est très rapide...

Il ne reste plus qu'à définir les 2 variables dans la procédure : FoldersList()

'============================================================== 'déclaration des variables, constantes et Api dans le
'haut d'un module standard :
Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type

Const FO_MOVE = 1
Const FO_COPY = 2
Const FO_DELETE = 3
Const FO_RENAME = 4

Const FOF_SILENT = 4
Const FOF_NOCONFIRMATION = 10

Private Declare Function SHFileOperationA Lib "Shell32.dll" _
(lpFileOp As SHFILEOPSTRUCT) As Long

'Déclaration des variables dans le haut du module
Dim FSO As Object
Dim myBaseFolder As Object
Dim myFolder As Object
Dim F As Object

'----------------------------------------------------
Sub FoldersList()
Dim répertoireSource As String
Dim RépertoireDestination As String

'********Définir les variables***********
répertoireSource = "c:denis"
RépertoireDestination = "c:denis1"
'Ne pas oublier le ""
'****************************************

Set FSO = CreateObject("scripting.filesystemobject")
On Error Resume Next
Call FoldersInFolder(répertoireSource, RépertoireDestination)
End Sub

Sub FoldersInFolder(myFolderName As String, Dest As String)
Dim Chemin As String
Set myBaseFolder = FSO.getfolder(myFolderName)
Chemin = myBaseFolder.Path & "*.xl*"
CopieDossier Chemin, Dest, FO_COPY, True
For Each myFolder In myBaseFolder.SubFolders
Call FoldersInFolder(myFolder.Path, Dest)
Next
End Sub
'----------------------------------------------------
Function CopieDossier(Source As String, Dest As String, _
Optional Action As Byte, Optional Animation As Boolean) As Boolean
Dim OpStruct As SHFILEOPSTRUCT

With OpStruct
.wFunc = Action
.pFrom = Source
.pTo = Dest
'POUR MESSAGE AVANT D'ÉCRASER : 4 AU LIEU DE 10
.fFlags = 4
End With
CopieDossier = IIf(SHFileOperationA(OpStruct), False, True)
End Function
'----------------------------------------------------
'==============================================================
MichD
--------------------------------------------

J'ai omis d'ajouter ceci au message précédent :

'-----------------------------------------------------------------------------------
Tu exécutes la procédure Test en choisissant une des actions
suivantes : FO_MOVE ,FO_COPY , FO_DELETE, FO_RENAME
l'usage des WildCard est permis *.xls ou *.* ou "P*.xls"
Ce qui permet d'avoir une action respectivement sur :
A ) Tous les fichiers Excel seulement "chemin*.xls"
B ) Tous les fichiers contenus dans le répertoire "chemin*.*"
C ) Tous les fichiers Excel dont le nom débute par la lettre P "cheminp*.*"
D ) On peut aussi utiliser le WidCard "?" qui remplace un caractère
dans le nom du fichier à l'endroit désigné
Exemple : "Fichier1.xls" on pourrait écrire : "CheminFichier?.xls" pour
obtenir tous les noms dont la racine est "fichier"+ un caractère .xls
'-----------------------------------------------------------------------------------


MichD
--------------------------------------------
"MichD" a écrit dans le message de groupe de discussion : ilipf1$i5l$1@speranza.aioe.org...

Une autre approche qui insère un API de Windows. Cette procédure permet de
copier tous les fichiers Excel du répertoire défini et de ses sous-répertoires.
Contrairement aux 2 autres procédures, elle permet de choisir si l'on désire
écraser ou non un fichier déjà existant dans le répertoire de destination.
De plus, elle est très rapide...

Il ne reste plus qu'à définir les 2 variables dans la procédure : FoldersList()

'============================================================== 'déclaration des variables, constantes et Api dans le
'haut d'un module standard :
Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type

Const FO_MOVE = 1
Const FO_COPY = 2
Const FO_DELETE = 3
Const FO_RENAME = 4

Const FOF_SILENT = 4
Const FOF_NOCONFIRMATION = 10

Private Declare Function SHFileOperationA Lib "Shell32.dll" _
(lpFileOp As SHFILEOPSTRUCT) As Long

'Déclaration des variables dans le haut du module
Dim FSO As Object
Dim myBaseFolder As Object
Dim myFolder As Object
Dim F As Object

'----------------------------------------------------
Sub FoldersList()
Dim répertoireSource As String
Dim RépertoireDestination As String

'********Définir les variables***********
répertoireSource = "c:denis"
RépertoireDestination = "c:denis1"
'Ne pas oublier le ""
'****************************************

Set FSO = CreateObject("scripting.filesystemobject")
On Error Resume Next
Call FoldersInFolder(répertoireSource, RépertoireDestination)
End Sub

Sub FoldersInFolder(myFolderName As String, Dest As String)
Dim Chemin As String
Set myBaseFolder = FSO.getfolder(myFolderName)
Chemin = myBaseFolder.Path & "*.xl*"
CopieDossier Chemin, Dest, FO_COPY, True
For Each myFolder In myBaseFolder.SubFolders
Call FoldersInFolder(myFolder.Path, Dest)
Next
End Sub
'----------------------------------------------------
Function CopieDossier(Source As String, Dest As String, _
Optional Action As Byte, Optional Animation As Boolean) As Boolean
Dim OpStruct As SHFILEOPSTRUCT

With OpStruct
.wFunc = Action
.pFrom = Source
.pTo = Dest
'POUR MESSAGE AVANT D'ÉCRASER : 4 AU LIEU DE 10
.fFlags = 4
End With
CopieDossier = IIf(SHFileOperationA(OpStruct), False, True)
End Function
'----------------------------------------------------
'==============================================================
MichD
--------------------------------------------