Extraire les fichiers Excel d'un répertoire ou d'un groupe de répertoire
1 réponse
Brumarj
Bonjour,
Je voudrai bâtir une macro me permettant d'extraire d'un répertoire ou d'une
serie de sous-repertoires, tous les fichiers Excel avec possibilité de les
copier par date sous un repertoire crée pour la circonstance dans "Mes
documents" ?
Y a t-il une bonne ame pouvant m'aider à construire cette macro ?
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
Bonsoir. Essaie avec précaution cette macro(mets le tout dans un module, la ligne Public ... doit être la première du module) Ce code est en grande partie dû à JB auquel il conviendra que tu associes tes remerciements, le cas échéant (les éventuelles erreurs seront les miennes). Note : le dossier de destination est "c:temp". A toi de mettre celui que tu veux. La ligne "Kill" qui supprime les classeurs après copie est mise en commentaire. Quand tu auras testé, enlève le '.
Public Dat As Date
Sub RechercheFichiers()
Dim Rep As String, Racine As String
With Application.FileDialog(msoFileDialogFolderPicker) .Show Racine = .SelectedItems(1) End With Rep = InputBox("Entrez la date") If IsDate(Rep) Then Dat = CDate(Rep) Else Exit Sub End If 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 CDate(Left(CStr(F.DateLastModified), 10)) = Dat And Right(F.Name, 4) = ".xls" Then Var = F.Path FileCopy F.Path, "c:temp" & F.Name 'Kill f.Path & "" & f.Name End If Next End Sub
Daniel "Brumarj" a écrit dans le message de news:
Bonjour, Je voudrai bâtir une macro me permettant d'extraire d'un répertoire ou d'une serie de sous-repertoires, tous les fichiers Excel avec possibilité de les copier par date sous un repertoire crée pour la circonstance dans "Mes documents" ?
Y a t-il une bonne ame pouvant m'aider à construire cette macro ?
Mille mercis d'avance,
Cordialement Bruno
Bonsoir.
Essaie avec précaution cette macro(mets le tout dans un module, la ligne
Public ... doit être la première du module)
Ce code est en grande partie dû à JB auquel il conviendra que tu associes
tes remerciements, le cas échéant (les éventuelles erreurs seront les
miennes).
Note : le dossier de destination est "c:temp". A toi de mettre celui que tu
veux. La ligne "Kill" qui supprime les classeurs après copie est mise en
commentaire. Quand tu auras testé, enlève le '.
Public Dat As Date
Sub RechercheFichiers()
Dim Rep As String, Racine As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
Racine = .SelectedItems(1)
End With
Rep = InputBox("Entrez la date")
If IsDate(Rep) Then
Dat = CDate(Rep)
Else
Exit Sub
End If
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 CDate(Left(CStr(F.DateLastModified), 10)) = Dat And Right(F.Name,
4) = ".xls" Then
Var = F.Path
FileCopy F.Path, "c:temp" & F.Name
'Kill f.Path & "" & f.Name
End If
Next
End Sub
Daniel
"Brumarj" <brumarj@wanadoo.fr> a écrit dans le message de news:
eB7fL16eIHA.6092@TK2MSFTNGP06.phx.gbl...
Bonjour,
Je voudrai bâtir une macro me permettant d'extraire d'un répertoire ou
d'une serie de sous-repertoires, tous les fichiers Excel avec possibilité
de les copier par date sous un repertoire crée pour la circonstance dans
"Mes documents" ?
Y a t-il une bonne ame pouvant m'aider à construire cette macro ?
Bonsoir. Essaie avec précaution cette macro(mets le tout dans un module, la ligne Public ... doit être la première du module) Ce code est en grande partie dû à JB auquel il conviendra que tu associes tes remerciements, le cas échéant (les éventuelles erreurs seront les miennes). Note : le dossier de destination est "c:temp". A toi de mettre celui que tu veux. La ligne "Kill" qui supprime les classeurs après copie est mise en commentaire. Quand tu auras testé, enlève le '.
Public Dat As Date
Sub RechercheFichiers()
Dim Rep As String, Racine As String
With Application.FileDialog(msoFileDialogFolderPicker) .Show Racine = .SelectedItems(1) End With Rep = InputBox("Entrez la date") If IsDate(Rep) Then Dat = CDate(Rep) Else Exit Sub End If 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 CDate(Left(CStr(F.DateLastModified), 10)) = Dat And Right(F.Name, 4) = ".xls" Then Var = F.Path FileCopy F.Path, "c:temp" & F.Name 'Kill f.Path & "" & f.Name End If Next End Sub
Daniel "Brumarj" a écrit dans le message de news:
Bonjour, Je voudrai bâtir une macro me permettant d'extraire d'un répertoire ou d'une serie de sous-repertoires, tous les fichiers Excel avec possibilité de les copier par date sous un repertoire crée pour la circonstance dans "Mes documents" ?
Y a t-il une bonne ame pouvant m'aider à construire cette macro ?
