Logo GNT
Actualités Tests & Guides Bons Plans
GTA 6 iPhone 17 Copilot Switch 2 Temu ChatGPT Tesla
OVH Cloud OVH Cloud
Entraide Applications Microsoft Office Excel création automatique de plusieurs fichiers excel à partir d'un s eu

création automatique de plusieurs fichiers excel à partir d'un s eu

13 réponses
Avatar
M'enfin
Bonjour à tous,

Je dispose d'un fichier excel qui constitue une base de données.
Dans cette base, je possède des données pouvant être triées par départements.
A partir de ce fichier, je souhaiterais générer automatiquement de nouveaux
fichiers excel propres à chaque département, nommer les fichiers créés en
fonction du nom du département et les placer dans un nouveau dossier portant
également le nom du département.
Ex : Ain.xls dans le dossier Dpt - Ain
Dpt - Aisnes.xls dans le dossier Aisnes...,etc
Pouvez vous m'aider ou m'aiguiller dans ma démarche ?
Merci d'avance
Signaler un problème avec ce contenu

3 réponses

Supprimer
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
1 2
Avatar
M''enfin
Merci, j'ai bien pris en compte les modifications
La macro ne bug plus du tout cependant la création des fichiers ne s'opère
pas.
Le répertoire maître "départements" est bien créé, la feuille "dpt" du
fichier source aussi, le filtre fonctionne puis un nouveau classeur est
ouvert mais l'enregistrement sous le nouveau nom ne fontionne pas et les
données issues du filtre sur la première valeur de C ne sont pas collées dans
le nouveau classeur.
Je pense que c'est au nouveau du sub Sauvefichier mais je n'arrive pas à
trouver la faille...


Bonjour,

Essayez de modifier la ligne
'*****
Sub SauveFichier(Wadd As Workbook, _
Departement As String, Id As String)
par
Sub SauveFichier(ByVal Wadd As Workbook, _
ByVal Departement As String, Id As String)
'*****

puis la ligne
'*****
Call SauveFichier(Wadd, C, Identifiant)
par
Call SauveFichier(Wadd, CStr(C), Identifiant)
'*****

Si cela fonctionne, n'oubliez pas de remercier Daniel
qui est à l'origine de cette solution.

Cordialement.
--
PMO
Patrick Morange



merci d'apporter vos reflexions à mon problème ;-)
j'ai remplacé l'ancienne macro par la nouvelle. Je voyais la logique de
résolution du problème mais je suis loin d'être très compétent en
macro....(j'avais fait à peu près le meme système de filtre par contre
j'étais coincé pour la génération des fichiers et pour les nommer.)
Cela étant la nouvelle macro bloque encore à l'instruction Call
SauveFichier(Wadd, C, Identifiant) avec comme message d'erreur :"Type
d'argument ByRef incompatible"
What's up doc(s) ?



Bonjour,

Je me permets de m'immiscer dans votre conversation et
de vous soumettre votre code modifié.

1) Dans les versions antérieures d'Excel et en ce qui concerne
la méthode Sort il n'existait pas d'argument DataOption1.
Il suffit de l'occulter.
2) J'ai créé une procédure SauveFichier qui fabrique, le cas
échéant, le dossier racine que j'ai appelé "Départements" et
les sous dossiers correspondant à chaque département et
dans lesquels s'enregistreront les classeurs Excel créés par
votre procédure.
3) Si l'utilisateur lance plusieurs fois votre programme, des
risques d'écrasement de fichiers déjà existants peuvent survenir.
Pour l'éviter, il suffit d'enregister ces classeurs avec un suffixe
unique. C'est la raison de la fonction IdUnique qui renvoie
une chaîne date et heure sous la forme yymmdd_hms
Exemple: 21 juillet 2005 14:10:27 donne 050721_141027
La date est inversée pour faciliter le tri dans l'exploration.

Ci-dessous le code
'**********
''### Constante à adapter ###
Const DOSSIER_MAITRE As String = "c:Départements"
''###########################
''___________________________
Sub test()
''°°° Macro de Daniel Colardelle °°°
''°°° modifiée par PMO °°°
''Création d'une feuille comportant
''une liste des départements
Dim Plage As Range, C As Range
Dim Identifiant$
Dim W As Workbook
Dim Wadd As Workbook
On Error GoTo Erreur
Application.ScreenUpdating = False
''---- Obtenir un identifiant unique ----
''_Année,Mois,Jour (inversé pour tri éventuel)
''et _Heure,Minute,Seconde (si procédure
''lancée plusieurs fois dans la même journée)
Identifiant = IdUnique
Sheets.Add
ActiveSheet.Name = "Dpt"
Sheets("Feuil1").Select
Range("E2", Range("E65536").End(xlUp)) _
.Copy Range("Dpt!B1")
Sheets("Dpt").Select
Range("B1", Range("B65536").End(xlUp)).Select
Selection.Sort Key1:=Range("B1"), _
Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:úlse, _
Orientation:=xlTopToBottom
'''' ARGUMENT INEXISTANT DANS VERSION ANTERIEURE
'''', DataOption1:=xlSortNormal
Range("A:A").ClearContents
Range("B1", Range("B65536").End(xlUp)) _
.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("A1"), Unique:=True
Set Plage = Range("A1", Range("A65536").End(xlUp))
Set W = ActiveWorkbook
For Each C In Plage
Set Wadd = Workbooks.Add
Application.StatusBar = _
"Enregistrement de " & UCase(C)
Call SauveFichier(Wadd, C, Identifiant)
W.Activate
Sheets("Feuil1").Select
With Range("A1", Range("E65536").End(xlUp))
.AutoFilter
.AutoFilter Field:=5, Criteria1:=C.Value
.SpecialCells(xlCellTypeVisible).Copy
End With
Windows(C & Identifiant & ".xls").Activate
ActiveSheet.Paste
Wadd.Save
Wadd.Close
Set Wadd = Nothing
Next C
Range("A1", Range("E65536").End(xlUp)).AutoFilter
Application.DisplayAlerts = False
W.Sheets("Dpt").Delete
Set W = Nothing
''---- Pseudo traitement d'erreur ----
Erreur:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
''___________________________
Sub SauveFichier(Wadd As Workbook, _
Departement As String, Id As String)
On Error GoTo Erreur
ChDir DOSSIER_MAITRE
MkDir UCase(Departement)
ChDir DOSSIER_MAITRE & "" & UCase(Departement)
Wadd.SaveAs Filename:=CurDir & "" _
& UCase(Departement) & Id & ""
Exit Sub
Erreur:
Select Case Err
Case 76
MkDir DOSSIER_MAITRE
ChDir DOSSIER_MAITRE
Resume Next
Case 75
Resume Next
End Select
End Sub
''___________________________
Private Function IdUnique() As String
IdUnique = "_" & Format(Date, "yymmdd") _
& "_" & Format(Time, "hns")
End Function
'**********

Cordialement.

--
PMO
Patrick Morange






Avatar
PMO
Bonjour,

Mon erreur doit être au niveau de l'argument Wadd

Ecrivez
'*****
Sub SauveFichier(Wadd As Workbook, _
ByVAL Departement As String, Id As String)

et non pas

SauveFichier(ByVal Wadd As Workbook, _
ByVal Departement As String, Id As String)
'*****



Cordialement.
--
PMO
Patrick Morange



Merci, j'ai bien pris en compte les modifications
La macro ne bug plus du tout cependant la création des fichiers ne s'opère
pas.
Le répertoire maître "départements" est bien créé, la feuille "dpt" du
fichier source aussi, le filtre fonctionne puis un nouveau classeur est
ouvert mais l'enregistrement sous le nouveau nom ne fontionne pas et les
données issues du filtre sur la première valeur de C ne sont pas collées dans
le nouveau classeur.
Je pense que c'est au nouveau du sub Sauvefichier mais je n'arrive pas à
trouver la faille...


Bonjour,

Essayez de modifier la ligne
'*****
Sub SauveFichier(Wadd As Workbook, _
Departement As String, Id As String)
par
Sub SauveFichier(ByVal Wadd As Workbook, _
ByVal Departement As String, Id As String)
'*****

puis la ligne
'*****
Call SauveFichier(Wadd, C, Identifiant)
par
Call SauveFichier(Wadd, CStr(C), Identifiant)
'*****

Si cela fonctionne, n'oubliez pas de remercier Daniel
qui est à l'origine de cette solution.

Cordialement.
--
PMO
Patrick Morange



merci d'apporter vos reflexions à mon problème ;-)
j'ai remplacé l'ancienne macro par la nouvelle. Je voyais la logique de
résolution du problème mais je suis loin d'être très compétent en
macro....(j'avais fait à peu près le meme système de filtre par contre
j'étais coincé pour la génération des fichiers et pour les nommer.)
Cela étant la nouvelle macro bloque encore à l'instruction Call
SauveFichier(Wadd, C, Identifiant) avec comme message d'erreur :"Type
d'argument ByRef incompatible"
What's up doc(s) ?



Bonjour,

Je me permets de m'immiscer dans votre conversation et
de vous soumettre votre code modifié.

1) Dans les versions antérieures d'Excel et en ce qui concerne
la méthode Sort il n'existait pas d'argument DataOption1.
Il suffit de l'occulter.
2) J'ai créé une procédure SauveFichier qui fabrique, le cas
échéant, le dossier racine que j'ai appelé "Départements" et
les sous dossiers correspondant à chaque département et
dans lesquels s'enregistreront les classeurs Excel créés par
votre procédure.
3) Si l'utilisateur lance plusieurs fois votre programme, des
risques d'écrasement de fichiers déjà existants peuvent survenir.
Pour l'éviter, il suffit d'enregister ces classeurs avec un suffixe
unique. C'est la raison de la fonction IdUnique qui renvoie
une chaîne date et heure sous la forme yymmdd_hms
Exemple: 21 juillet 2005 14:10:27 donne 050721_141027
La date est inversée pour faciliter le tri dans l'exploration.

Ci-dessous le code
'**********
''### Constante à adapter ###
Const DOSSIER_MAITRE As String = "c:Départements"
''###########################
''___________________________
Sub test()
''°°° Macro de Daniel Colardelle °°°
''°°° modifiée par PMO °°°
''Création d'une feuille comportant
''une liste des départements
Dim Plage As Range, C As Range
Dim Identifiant$
Dim W As Workbook
Dim Wadd As Workbook
On Error GoTo Erreur
Application.ScreenUpdating = False
''---- Obtenir un identifiant unique ----
''_Année,Mois,Jour (inversé pour tri éventuel)
''et _Heure,Minute,Seconde (si procédure
''lancée plusieurs fois dans la même journée)
Identifiant = IdUnique
Sheets.Add
ActiveSheet.Name = "Dpt"
Sheets("Feuil1").Select
Range("E2", Range("E65536").End(xlUp)) _
.Copy Range("Dpt!B1")
Sheets("Dpt").Select
Range("B1", Range("B65536").End(xlUp)).Select
Selection.Sort Key1:=Range("B1"), _
Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:úlse, _
Orientation:=xlTopToBottom
'''' ARGUMENT INEXISTANT DANS VERSION ANTERIEURE
'''', DataOption1:=xlSortNormal
Range("A:A").ClearContents
Range("B1", Range("B65536").End(xlUp)) _
.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("A1"), Unique:=True
Set Plage = Range("A1", Range("A65536").End(xlUp))
Set W = ActiveWorkbook
For Each C In Plage
Set Wadd = Workbooks.Add
Application.StatusBar = _
"Enregistrement de " & UCase(C)
Call SauveFichier(Wadd, C, Identifiant)
W.Activate
Sheets("Feuil1").Select
With Range("A1", Range("E65536").End(xlUp))
.AutoFilter
.AutoFilter Field:=5, Criteria1:=C.Value
.SpecialCells(xlCellTypeVisible).Copy
End With
Windows(C & Identifiant & ".xls").Activate
ActiveSheet.Paste
Wadd.Save
Wadd.Close
Set Wadd = Nothing
Next C
Range("A1", Range("E65536").End(xlUp)).AutoFilter
Application.DisplayAlerts = False
W.Sheets("Dpt").Delete
Set W = Nothing
''---- Pseudo traitement d'erreur ----
Erreur:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
''___________________________
Sub SauveFichier(Wadd As Workbook, _
Departement As String, Id As String)
On Error GoTo Erreur
ChDir DOSSIER_MAITRE
MkDir UCase(Departement)
ChDir DOSSIER_MAITRE & "" & UCase(Departement)
Wadd.SaveAs Filename:=CurDir & "" _
& UCase(Departement) & Id & ""
Exit Sub
Erreur:
Select Case Err
Case 76
MkDir DOSSIER_MAITRE
ChDir DOSSIER_MAITRE
Resume Next
Case 75
Resume Next
End Select
End Sub
''___________________________
Private Function IdUnique() As String
IdUnique = "_" & Format(Date, "yymmdd") _
& "_" & Format(Time, "hns")
End Function
'**********

Cordialement.

--
PMO
Patrick Morange








Avatar
M''enfin
Non ce n'est pas ça, j'ai déjà essayé :-(



Bonjour,

Mon erreur doit être au niveau de l'argument Wadd

Ecrivez
'*****
Sub SauveFichier(Wadd As Workbook, _
ByVAL Departement As String, Id As String)

et non pas

SauveFichier(ByVal Wadd As Workbook, _
ByVal Departement As String, Id As String)
'*****



Cordialement.
--
PMO
Patrick Morange



Merci, j'ai bien pris en compte les modifications
La macro ne bug plus du tout cependant la création des fichiers ne s'opère
pas.
Le répertoire maître "départements" est bien créé, la feuille "dpt" du
fichier source aussi, le filtre fonctionne puis un nouveau classeur est
ouvert mais l'enregistrement sous le nouveau nom ne fontionne pas et les
données issues du filtre sur la première valeur de C ne sont pas collées dans
le nouveau classeur.
Je pense que c'est au nouveau du sub Sauvefichier mais je n'arrive pas à
trouver la faille...


Bonjour,

Essayez de modifier la ligne
'*****
Sub SauveFichier(Wadd As Workbook, _
Departement As String, Id As String)
par
Sub SauveFichier(ByVal Wadd As Workbook, _
ByVal Departement As String, Id As String)
'*****

puis la ligne
'*****
Call SauveFichier(Wadd, C, Identifiant)
par
Call SauveFichier(Wadd, CStr(C), Identifiant)
'*****

Si cela fonctionne, n'oubliez pas de remercier Daniel
qui est à l'origine de cette solution.

Cordialement.
--
PMO
Patrick Morange



merci d'apporter vos reflexions à mon problème ;-)
j'ai remplacé l'ancienne macro par la nouvelle. Je voyais la logique de
résolution du problème mais je suis loin d'être très compétent en
macro....(j'avais fait à peu près le meme système de filtre par contre
j'étais coincé pour la génération des fichiers et pour les nommer.)
Cela étant la nouvelle macro bloque encore à l'instruction Call
SauveFichier(Wadd, C, Identifiant) avec comme message d'erreur :"Type
d'argument ByRef incompatible"
What's up doc(s) ?



Bonjour,

Je me permets de m'immiscer dans votre conversation et
de vous soumettre votre code modifié.

1) Dans les versions antérieures d'Excel et en ce qui concerne
la méthode Sort il n'existait pas d'argument DataOption1.
Il suffit de l'occulter.
2) J'ai créé une procédure SauveFichier qui fabrique, le cas
échéant, le dossier racine que j'ai appelé "Départements" et
les sous dossiers correspondant à chaque département et
dans lesquels s'enregistreront les classeurs Excel créés par
votre procédure.
3) Si l'utilisateur lance plusieurs fois votre programme, des
risques d'écrasement de fichiers déjà existants peuvent survenir.
Pour l'éviter, il suffit d'enregister ces classeurs avec un suffixe
unique. C'est la raison de la fonction IdUnique qui renvoie
une chaîne date et heure sous la forme yymmdd_hms
Exemple: 21 juillet 2005 14:10:27 donne 050721_141027
La date est inversée pour faciliter le tri dans l'exploration.

Ci-dessous le code
'**********
''### Constante à adapter ###
Const DOSSIER_MAITRE As String = "c:Départements"
''###########################
''___________________________
Sub test()
''°°° Macro de Daniel Colardelle °°°
''°°° modifiée par PMO °°°
''Création d'une feuille comportant
''une liste des départements
Dim Plage As Range, C As Range
Dim Identifiant$
Dim W As Workbook
Dim Wadd As Workbook
On Error GoTo Erreur
Application.ScreenUpdating = False
''---- Obtenir un identifiant unique ----
''_Année,Mois,Jour (inversé pour tri éventuel)
''et _Heure,Minute,Seconde (si procédure
''lancée plusieurs fois dans la même journée)
Identifiant = IdUnique
Sheets.Add
ActiveSheet.Name = "Dpt"
Sheets("Feuil1").Select
Range("E2", Range("E65536").End(xlUp)) _
.Copy Range("Dpt!B1")
Sheets("Dpt").Select
Range("B1", Range("B65536").End(xlUp)).Select
Selection.Sort Key1:=Range("B1"), _
Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:úlse, _
Orientation:=xlTopToBottom
'''' ARGUMENT INEXISTANT DANS VERSION ANTERIEURE
'''', DataOption1:=xlSortNormal
Range("A:A").ClearContents
Range("B1", Range("B65536").End(xlUp)) _
.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("A1"), Unique:=True
Set Plage = Range("A1", Range("A65536").End(xlUp))
Set W = ActiveWorkbook
For Each C In Plage
Set Wadd = Workbooks.Add
Application.StatusBar = _
"Enregistrement de " & UCase(C)
Call SauveFichier(Wadd, C, Identifiant)
W.Activate
Sheets("Feuil1").Select
With Range("A1", Range("E65536").End(xlUp))
.AutoFilter
.AutoFilter Field:=5, Criteria1:=C.Value
.SpecialCells(xlCellTypeVisible).Copy
End With
Windows(C & Identifiant & ".xls").Activate
ActiveSheet.Paste
Wadd.Save
Wadd.Close
Set Wadd = Nothing
Next C
Range("A1", Range("E65536").End(xlUp)).AutoFilter
Application.DisplayAlerts = False
W.Sheets("Dpt").Delete
Set W = Nothing
''---- Pseudo traitement d'erreur ----
Erreur:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
''___________________________
Sub SauveFichier(Wadd As Workbook, _
Departement As String, Id As String)
On Error GoTo Erreur
ChDir DOSSIER_MAITRE
MkDir UCase(Departement)
ChDir DOSSIER_MAITRE & "" & UCase(Departement)
Wadd.SaveAs Filename:=CurDir & "" _
& UCase(Departement) & Id & ""
Exit Sub
Erreur:
Select Case Err
Case 76
MkDir DOSSIER_MAITRE
ChDir DOSSIER_MAITRE
Resume Next
Case 75
Resume Next
End Select
End Sub
''___________________________
Private Function IdUnique() As String
IdUnique = "_" & Format(Date, "yymmdd") _
& "_" & Format(Time, "hns")
End Function
'**********

Cordialement.

--
PMO
Patrick Morange










1 2