Discussion :

[jpvba]

Bonjour a vous chers amis du forum.


Afin d'automatisé une tâche et sauvé du temps et évités les erreurs, je voudrais a partir d'un fichier contenant deux onglets (un croisé dynamique, l'autre un tableau auquel le TCD a été généré avec ses données) générés plusieurs documents excel selon le contenu du tableau ou le tableau croisée dynamique selon la faisabilité.


Le tableau a plusieurs colonnes dont la lettre n (la qté), la lettre O (catégorie), la lettre P (sous-catégorie), la lettre Q (descriptions). Le tableau croisé dynamique contient les mêmes éléments mais les qtés sont additionnés selon les descriptions.

J'ai un fichier modele appelé modele_BP.xlsm (étant donné qu'il y a un message de consigne a l'ouverture de celui-ci, j'utilise le fichier avec macro) contenant deux onglets. La première feuille intitulé informations générale contient une page de présentation et une feuille appelé travail.



Donc je voudrais, que pour mon tableau (ou le tableau dynamique) du départ, pour chacune des catégories (colonne O) ouvrir le fichier modele_BP, le sauvegardé selon chacun des noms différents (donc créés autant de fichier qu'il y a de catégories différentes), mettre le nom de la catégorie dans la cellules D2 à la suite du texte que j'ai présentement.

Ensuite, pour chacune des descriptions qui ont la catégorie identique au nom du fichier, renommer et copier le nom de la description à la feuille Travail afin de garder la mise en forme. Dans chacune des feuilles portant le nom de la descriptions, je dois inscrire à la cellule A5 le nom de la sous catégorie, le nom de la description à la cellule B5. Ainsi que la qté totale a la cellule F1 (d'où là la question du croisée dynamique).


Donc pour résumé je dois créé a partir d'un tableau autant de fichier qu'il y a de catégories. Pour chacun des fichiers il dois y avoir autant d'onglet qu'il y a de descriptions + la page de présentation.

Il se peut qu'il y ait des changements dans le tableau donc on doit etre en mesure de régénéré les fichiers (possiblement détruire s'il y a des ajouts de catégories ou de descriptions).

Cetaines descriptions on plus que le nombre de caractère toléré pour une feuille d'excel donc il faudrait tronqué le nom selon le début ou la fin toute en s'assurant que le tronquage ne crée pas de doublons. Également les fichiers pourrais etre sauvegarder à l'emplacement du fichier de départ


Donc je suis vraiment embêté devant ce mastodonte qui est devant moi

1erement j'ai tenté d'utilisé le TCD et je n'ai pas réussis à l'utilisé donc les tentatives infructueuses ont été fais avec le tableau.

Ou que j'accroche bêtement est la génération des fichiers ainsi que la population du nombre d'onglet.

Mon réflexe naturel est la boucle mais j'ai également pensée à l'utilisation du filtre élaboré. Mes utilisations antérieures du filtre élaborés sont dans une circonstance auquel il y avait un x dans une case et on ramenais des données mais là je ne sais du tout si c'est un idée envisageable ou non, et si il y aurait un gain.



Si vous voulez une copie des fichier en xlsx, je pourrais les ajouter sans problème.


Je vous met également une partie du code que j'ai commencé à élaboré, mais c'Est vraiment brouillons (version boucle)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
Dim categorie As Variant
Dim x As Integer
Dim chemin As String
Dim Fullname As String
 
chemin = ActiveWorkbook.Path & "" '
 
 
 
Application.ScreenUpdating = False
 
'validation de la feuille Sommaire final et filtre
 
    If sheetExists("Sommaire final") = False Then
        MsgBox "Feuille  ""Sommaire final"" manquante", vbCritical
        Exit Sub
    End If
 
 
    For Each categorie In Sheets("Sommaire final").Range("o2, o" & LastLignUsedInColumn("o"))
 
        x = x + 1
        Fullname = chemin & "\" & categorie.Value & "_" & ".xlsm"
 
                If sheetExists(categorie.Value) = True And IsFileExist(Fullname) = False Then
                        Sheets(categorie.Value).Copy
                        ActiveWorkbook.SaveAs Filename:=chemin & "\" & categorie.Value & ".xlsm" _
                                , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                        ActiveWorkbook.Close
                End If
 
    Next categorie
 
    Application.ScreenUpdating = True
 
 
End Sub

Dont les functions suivante sont utilisés

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
Function sheetExists(Feuille) As Boolean ' Code Fait par Marc-L
         sheetExists = Evaluate("ISREF('" & Feuille & "'!A1)")
End Function
 
Function IsFileExist(Fullname As String) As Boolean
        IsFileExist = Dir(Fullname) <> ""
    End Function

merci mille fois pour votre aide ... j'en ai vraiment besoin car je suis complètement découragée

[jpvba]

Voici ou que je suis présentement dans mon code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
Sub generation_onglet_BP_Angio()
 
Dim categorie As Variant
Dim chemin As String
Dim Fullname As String
Dim wbdepart As Workbook
Dim wbmodele As Workbook
Dim oDescription As Variant
 
 
Set wbdepart = ActiveWorkbook
 
'
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
 
 
'validation de la feuille Sommaire final et filtre
 
    If sheetExists("Sommaire final") = False Then
        MsgBox "Feuille  ""Sommaire final"" manquante", vbCritical
        Exit Sub
    End If
 
 
    For Each categorie In wbdepart.Sheets("Sommaire final").Range("o2: o" & LastLignUsedInColumn("o"))
 
Fullname = "N:\FOURNITURES\FOURNITURES SPECIALISEES  ANGIOGRAPHIE\2019-0744-01\1-PRE_MA_MA\1.6-BP\" & categorie.Value
 
        If IsFileExist(Fullname) = False Then
 
            Application.EnableEvents = False
 
            Workbooks.Open ("N:\FOURNITURES\FOURNITURES SPECIALISEES  ANGIOGRAPHIE\2019-0744-01\1-PRE_MA_MA\1.6-BP\modele_BP.xlsm")
 
            Application.EnableEvents = True
 
            Set wbmodele = ActiveWorkbook
 
            wbmodele.Sheets("INFORMATIONS GENERALES").Range("a3") = categorie
 
 
            wbdepart.Activate
 
          For Each oDescription In wbdepart.Sheets("Sommaire final").Range("q2: q" & LastLignUsedInColumn("q"))
 
                If sheetExists(oDescription.Value) = False Then
                    wbmodele.Sheets("Travail").Copy Before:=wbmodele.Sheets(1)
                    ActiveSheet.Name = oDescription.Value
                    Range("b5") = oDescription.Value
                Else
 
                End If
           Next oDescription
 
 
        End If
 
'sauvegarder le fichier selon le nom de la catégorie et le fermer
wbmodele.SaveAs "N:\FOURNITURES\FOURNITURES SPECIALISEES  ANGIOGRAPHIE\2019-0744-01\1-PRE_MA_MA\1.6-BP\BP_" & categorie.Value, xlOpenXMLWorkbookMacroEnabled
wbmodele.Close xlNo
 
 
 
    Next categorie
 
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
 
MsgBox "Les fichiers ont été créé dans le répertoire N:\FOURNITURES\FOURNITURES SPECIALISEES  ANGIOGRAPHIE\2019-0744-01\1-PRE_MA_MA\1.6-BP\"
 
End Sub

Donc j'ai une boucle dans une boucle, ce qui est vraiment vraiment lent. J plente car le nom de la feuille dépasse 31 caractères.

Est-ce que vous auriez une solution afin de tronquer automatiquent a 31 caractères ???



Également auriez vous une façon plus rapide que la boucle dans la boucle ...


Je sais que je vais également me buter a un mur lorsque je vais vouloir inscrire dans les feuilles les informations de départ étant donné que je n'y vais pas par ligne


merci a vous ... j'ai malheureusement un délai serré que l'on m'a accordé afin de réussir donc toute les idées sont les bienvenues !!!

[jpvba]

Re-Bonjour,


J'ai eu un flash, j'ai décidé de copier la feuille de départ et d'enlever les doublons sur la colonne contenant les catégories et par la suite faire un filtre élaboré afin d'avoir toute les descriptions possible pour chacune des catégories.


J'ai seulement un message d'erreur suivant


avec le code ci-dessous

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
Sub generation_onglet_BP_Angio2()
Dim oCategorie As Variant
Dim chemin As String
Dim Fullname As String
Dim wbDepart As Workbook
Dim wbmodele As Workbook
Dim oDescription As Variant
 
Set wbDepart = ActiveWorkbook
 
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
 
'validation de la feuille Sommaire final et filtre
 
    If sheetExists("Sommaire final") = False Then
        MsgBox "Feuille  ""Sommaire final"" manquante", vbCritical
        Exit Sub
    End If
 
   If sheetExists("filtre_cat") Then Sheets("filtre_cat").Delete
 
'copy de la feuille filtre_descript l'enlever les doublons de catégorie et la renommer
 
Sheets("Sommaire final").Copy After:=Sheets(2)
ActiveSheet.Name = "filtre_cat"
Sheets("filtre_cat").Range("A1:s" & LastLignUsedInColumn("s")).RemoveDuplicates Columns:=15, Header:=xlYes
 
 
For Each oCategorie In wbDepart.Sheets("filtre_cat").Range("o2: o" & LastLignUsedInColumn("o"))
 
Fullname = "N:\FOURNITURES\FOURNITURES SPECIALISEES  ANGIOGRAPHIE\2019-0744-01\1-PRE_MA_MA\1.6-BP\" & oCategorie.Value
 
        If IsFileExist(Fullname) = False Then
 
            Application.EnableEvents = False
 
            Workbooks.Open ("N:\FOURNITURES\FOURNITURES SPECIALISEES  ANGIOGRAPHIE\2019-0744-01\1-PRE_MA_MA\1.6-BP\modele_BP.xlsm")
 
            Application.EnableEvents = True
 
            Set wbmodele = ActiveWorkbook
 
            wbmodele.Sheets("INFORMATIONS GENERALES").Range("a3") = oCategorie.Value
 
 
            wbDepart.Activate
 
 
 
        End If
 
'sauvegarder le fichier selon le nom de la catégorie et le fermer
wbmodele.SaveAs "N:\FOURNITURES\FOURNITURES SPECIALISEES  ANGIOGRAPHIE\2019-0744-01\1-PRE_MA_MA\1.6-BP\BP_" & oCategorie.Value, xlOpenXMLWorkbookMacroEnabled
wbmodele.Close xlYes
 
 
 
    Next oCategorie
 
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
 
 
MsgBox "Les fichiers ont été créé dans le répertoire N:\FOURNITURES\FOURNITURES SPECIALISEES  ANGIOGRAPHIE\2019-0744-01\1-PRE_MA_MA\1.6-BP\"
 
End Sub

avec cette façon de faire je sais que je vais quand meme avoir un probleme afin de mettre la quantité totale dans chacune des feuilles correspondants a chacune des description ainsi que l'information de la sous-catégorie

[halaster08]

Donc je voudrais, que pour mon tableau (ou le tableau dynamique) du départ, pour chacune des catégories (colonne O) ouvrir le fichier modele_BP, le sauvegardé selon chacun des noms différents (donc créés autant de fichier qu'il y a de catégories différentes)

Un exemple ici:https://www.developpez.net/forums/d1...l/#post7190633
A adapter a ton cas

[jpvba]

Merci beaucoup Halaster pour ton post,


Mais le document fais par monsieur Tulliez ne fais pas la somme des qtés ... donc pour cette partie je vais encore avoir un problème

[halaster08]

Mais le document fais par monsieur Tulliez ne fais pas la somme des qtés ... donc pour cette partie je vais encore avoir un problème

J'avoue ne pas avoir bien compris ce que tu cherches a faire après avoir créer tes classeurs.
Cependant vu que tu as besoin de créer ces classeurs autant te servir cet exemple comme base, tu verras par la suite comme compléter ce code

[jpvba]

Bonjour Halaster,


J'ai trouvé une solution, i.e. faire un filtre sur un second critère pour avoir les qté de ce critères, faire la somme, etc ...



Oui effectivement mon cas est dur a expliqué sans les classeur et sans jasé. Pour comprendre le besoin des utilisateurs, ça m'a également pris un peu de temps


JE vous tiens au courant si jamais cela pourrais également servir a quelqu'un d'autre du forum

[jpvba]

Salut groupe,


Voici ce que donne mon code ... oui présentement j'ai mis on error resume next, mais il va bientot disparaitre selon vos conseilles

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
Sub generation_onglet_BP_Angio2()
 
On Error Resume Next
 
Dim oCategorie As Variant
Dim Fullname As String
Dim wbDepart As Workbook
Dim wbmodele As Workbook
Dim x As Long
Dim feuil_filtre As Variant
Dim ws As Variant
Dim oDesc_AO As Variant
Dim plage_qte As Range
 
feuil_filtre = Array("filtre_cat", "filtre_elab", "filtre_desc")
 
Set wbDepart = ActiveWorkbook
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
 
'validation de la feuille Sommaire final
 
   If sheetExists("Sommaire final") = False Then
        MsgBox "Feuille  ""Sommaire final"" manquante", vbCritical
        Exit Sub
   End If
 
'desctruction des feuille filtre si déjà présente
   For Each ws In feuil_filtre
 
   If sheetExists(ws) Then Sheets(ws).Delete
 
   Next ws
 
   'une fois supprimer on enleve les reference dans le gestionnaire de noms
 
supprNomRef
 
'copy de la feuille sommaire enlever les doublons de catégorie et la renommer
 
Sheets("Sommaire final").Copy After:=Sheets(1)
ActiveSheet.Name = "filtre_cat"
Sheets("filtre_cat").Range("A1:s" & LastLignUsedInColumn("P")).RemoveDuplicates Columns:=15, Header:=xlYes
 
 
 
'on créé la feulle pour le filtre élaboré
Sheets.Add.Name = "filtre_elab"
 
Sheets("filtre_elab").Range("a1") = Sheets("Sommaire final").Range("o1")
Sheets("filtre_elab").Range("e1") = Sheets("Sommaire final").Range("p1")
Sheets("filtre_elab").Range("f1") = Sheets("Sommaire final").Range("q1")
 
 
'on créé la feulle pour le filtre description
Sheets.Add.Name = "filtre_desc"
Sheets("filtre_desc").Range("a1") = Sheets("Sommaire final").Range("q1")
Sheets("filtre_desc").Range("e1") = Sheets("Sommaire final").Range("n1")
Sheets("filtre_desc").Range("f1") = Sheets("Sommaire final").Range("p1")
Sheets("filtre_desc").Range("j1") = "TOTAL"
 
 
 
 
'on nomme la plage départ afin de facilité le travail
 
Sheets("Sommaire final").Range("a2").CurrentRegion.Name = "plage_depart"
 
 
'on nomme la plage de destination afin de facilité le code
 
Sheets("filtre_elab").Range("e2").CurrentRegion.Name = "destination"
 
 
Sheets("filtre_cat").Activate
 
For Each oCategorie In wbDepart.Sheets("filtre_cat").Range("o2", Range("o1").End(xlDown))
 
x = x + 1
 
Sheets("filtre_elab").Range("a2") = Sheets("filtre_cat").Cells(x + 1, 15)
 
Sheets("Sommaire final").Range("plage_depart").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
    Sheets("filtre_elab").Range("A1:a2"), CopyToRange:=Sheets("filtre_elab").Range("destination"), Unique:=True
 
Sheets("filtre_elab").Activate
 
 
 
    Fullname = "N:\FOURNITURES\FOURNITURES SPECIALISEES  ANGIOGRAPHIE\2019-0744-01\BP\" & oCategorie.value
 
 
            Application.EnableEvents = False
 
            Workbooks.Open ("N:\FOURNITURES\FOURNITURES SPECIALISEES  ANGIOGRAPHIE\2019-0744-01\BP\modele_BP.xlsm")
 
            Application.EnableEvents = True
 
            Set wbmodele = ActiveWorkbook
 
            wbmodele.Sheets("INFORMATIONS GENERALES").Range("a3") = oCategorie.value
 
 
        wbDepart.Activate
 
'filtre plus onglets
    For Each oDesc_AO In wbDepart.Sheets("filtre_elab").Range("f2", Range("f1").End(xlDown))
        wbDepart.Activate
 
        wbDepart.Sheets("filtre_desc").Range("a2") = oDesc_AO.value
 
        wbDepart.Sheets("Sommaire final").Range("plage_depart").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
        wbDepart.Sheets("filtre_desc").Range("A1:a2"), CopyToRange:=wbDepart.Sheets("filtre_desc").Range("e1:f2"), Unique:=False
 
        wbDepart.Sheets("filtre_desc").Activate
        Set plage_qte = wbDepart.Sheets("filtre_desc").Range("e2", Range("e1").End(xlDown))
 
        wbDepart.Sheets("filtre_desc").Range("j2") = Application.WorksheetFunction.Sum(plage_qte)
 
        wbmodele.Activate
        wbmodele.Sheets("Travail").Copy After:=Sheets(1)
        ActiveSheet.Name = Right(oDesc_AO.value, 31)
 
        wbmodele.Sheets(Right(oDesc_AO.value, 31)).Range("f1") = wbDepart.Sheets("filtre_desc").Range("j2")
        wbmodele.Sheets(Right(oDesc_AO.value, 31)).Range("b5") = oDesc_AO.value
        wbmodele.Sheets(Right(oDesc_AO.value, 31)).Range("a5") = wbDepart.Sheets("filtre_desc").Range("f2")
        wbDepart.Activate
    Next oDesc_AO
 
    wbmodele.SaveAs "N:\FOURNITURES\FOURNITURES SPECIALISEES  ANGIOGRAPHIE\2019-0744-01\BP\BP_" & oCategorie.value, xlOpenXMLWorkbookMacroEnabled
    wbmodele.Close xlYes
 
 
Next oCategorie
 
    wbDepart.Activate
 
'on détruis les feuilles créés
 
For Each ws In feuil_filtre
 
Sheets(ws).Delete
 
Next ws
 
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
 
 
MsgBox "Les fichiers ont été créé dans le répertoire N:\FOURNITURES\FOURNITURES SPECIALISEES  ANGIOGRAPHIE\2019-0744-01\BP\"
 
End Sub

Ce que j'ai présentement comme problème c'est qu'il y a des descriptions qui dépasse les 31 caractères ... pourquoi l'utilisation de right mais il y a-t-il une façon de dire si jamais le nom est déjà pris ajouté un chiffre différent ???


merci pour votre aide précieuse