Résultat avec un critère dans un array, est-ce possible ?

**jpvba** · 01/10/2018, 15h52

Bonjour monsieur Tulliez,

Il s'agit effectivement de copié les lignes d'un array qui ne sont pas contiguë vers un autre feuille lorsque qu’il y a un X ou x dans une certaine colonne.

Toute les exemple que j'ai vu sur le web copie la totalité du array et non une section et ce a l'aide d'une variable array et non avec la function array qui est utilisé dans ma situation. Avec la logique et aide de monsieur Toulon, je suis arrive avec une transposition dans une nouvelle feuille. Cette transposition n'est pas vertical mais horizontal (transposition d'une ligne en colonne). Elle répond également a mon critère du fameux X ou x à l'aide de mon premier si que je réutilise pour la partie de la function array.

Code :

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

1
2
3
4
5
6
7
8
9
tableau_reponse = Array(tableau1(x, 1), tableau2(x, 1), tableau3(x, 1), tableau4(x, 1), tableau5(x, 1), _
                  tableau6(x, 1), tableau7(x, 1), tableau8(x, 1), tableau9(x, 1), tableau10(x, 1), _
                  tableau11(x, 1), tableau12(x, 1), tableau13(x, 1), tableau14(x, 1), tableau15(x, 1), _
                  tableau16(x, 1), tableau17(x, 1), tableau18(x, 1))
 
 
 
Debug.Print Join(tableau_reponse, ";")
Sheets(nom_etablissement.value).Range("a" & x + 1).Resize(UBound(tableau_reponse) + 1, 1) = Application.Transpose(tableau_reponse)

Voici ce que je veux obtenir

Nom : Capture1.JPG
Affichages : 257
Taille : 114,3 Ko

et voici ce qu j'obtiens avec le code ci-haut (mon titre est a la bonne endroit)

Nom : Capture2.JPG
Affichages : 249
Taille : 47,5 Ko

Il faut seulement que la ligne sois en ligne et non ligne en colonne et mon cas est réglé

**RyuAutodidacte** · 01/10/2018, 16h55

Bonjour,

Ingrédient pour faire le code :
• l'ensemble de ta plage de tes données dans un Range
• une variable tableau qui contient la plage de tes données (via le range)
• une autre variable tableau pour transposer tes données et qui sera dimensionnée via un CountIf sur la colonne ou se trouve les X et le nombre de colonne de ton nouveau tableau

- on parcours dans la variable des données la colonne ou se trouve les X via une boucle
- dans la condition où l'on trouve un X (utilisation d'un If),
on fait une incrémentation de 1 (pour une correspondance avec la ligne réceptrice du second tableau(tableau à 2 dimensions)),
puis on récupère les valeurs que l'on veut dans la variable tableau des données en les faisant la correspondance avec la variable tableau réceptrice

ça c'est pour le principe dans les grandes lignes

- Dans cette discussion je donne des liens et des exemples et explications avec des variables tableaux - un peu de lecture ne fait jamais de mal …

https://www.developpez.net/forums/d1...bleaux-pertes/

Autre solution possible pour avancer :
Utilisation d'un filtre avancé afin de pouvoir transposer ou transposer les données finales sur une autre feuille (voir comment sont les données d'origines)
=> cela permettra de sélectionner toutes les lignes contenant des X et de sélectionner les colonnes voulues : voir le lien :
https://philippetulliez.developpez.c...dvancedfilter/

Quoiqu'il en soit sans une réelle connaissance des données initiales (même si l'on utilise de fausse données du moment que cela représente la réalité),
difficile de pondre un code correct

**Philippe Tulliez** · 01/10/2018, 18h47

Bonjour,
Pour exporter suivant critères avec la méthode AdvancedFilter. Le critère pour l'exemple <> de X

Attention : Il s'agit de l'exportation d'une liste de données avec ou sans critère (pour l'exemple il y a un critère) vers une cellule cible.
La plage source, des critères (s'il y en a) ainsi que la plage cible peut se trouver sur la même feuille, d'autres feuilles et MËME d'autres classeurs.
On peut exporter toutes les colonnes ou UNE PARTIE.
On peut exporter sans les doublons
On peut aussi filtrer sur place et DONC aussi supprimer suivant critères

Pour bien comprendre comment fonctionne les filtres avancés, la lecture de ce tutoriel Les filtres avancés ou élaborés dans Excel s'impose

Exemple 1 : Exporter toutes les colonnes

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
Sub TestAdvancedFilter_AllLabels()
  ' Déclaration des variables
  Dim areaSource As Range
  Dim areaCriteria As Range
  Dim areaTarget As Range
  ' Assignation des variables
  With ThisWorkbook.Worksheets("Feuil1")
    Set areaSource = .Range("A1").CurrentRegion
    Set areaCriteria = .Range("G1:G2")
    Set areaTarget = .Range("I1")
  End With
  ' Supprime les données précédentes
  areaTarget.CurrentRegion.Clear
  ' Exporte suivant conditions
  areaSource.AdvancedFilter xlFilterCopy, areaCriteria, areaTarget
  ' Fin de programme
  Set areaSource = Nothing: Set areaCriteria = Nothing: Set areaTarget = Nothing
End Sub

Exemple 2 - Exporter une partie des colonnes

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
Sub TestAdvancedFilter_SomeLabels()
  ' Déclaration des variables et constante
  Const LabelList = "Ref;Montant;Nom"
  Dim areaSource As Range
  Dim areaCriteria As Range
  Dim areaTarget As Range
  ' Assignation des variables
  With ThisWorkbook.Worksheets("Feuil1")
    Set areaSource = .Range("A1").CurrentRegion
    Set areaCriteria = .Range("G1:G2")
    Set areaTarget = .Range("I1")
  End With
  '
  With areaTarget
  ' Supprime les données précédentes
  .CurrentRegion.Clear
  ' Place les étiquettes à exporter sous forme de chaînes (Const LabelList)
  '  & Transfert le texte séparé par ; en colonnes
  .Value = LabelList: .TextToColumns Semicolon:=True, DataType:=xlDelimited
  ' Redefini la zone cible
   Set areaTarget = areaTarget.CurrentRegion
  End With
  ' Exporte suivant conditions
  areaSource.AdvancedFilter xlFilterCopy, areaCriteria, areaTarget
  ' Fin de programme
  Set areaSource = Nothing: Set areaCriteria = Nothing: Set areaTarget = Nothing
End Sub

Illustration Exemple 2

Nom : 181001 AdvancedFilter.png
Affichages : 255
Taille : 24,8 Ko

**RyuAutodidacte** · 01/10/2018, 21h19

Coucou Philippe

pour les précisions

PS : je pense que @jpvba ne loupera pas le lien avec celui-ci dans 2 posts d'affilés

**jpvba** · 03/10/2018, 01h47

MErci beaucoup pour le complément d'information, je suis en grosse lecture.

Les liens de Ryu parle de lien d'un poste qui mènent dans un autre poste ainsi de suite. >Je vais donc lire attentivement les postes afin de pouvoir voir l'information nécessaire a la réussite de mon problème

En attendant je vais donc mettre mon code initiale

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
Sub genere_onglets_etablissement_ancien()
 
    On Error GoTo errorhandler:
 
    Dim x As Integer
    Dim LettreVoulue As String
    LettreVoulue = TrouveLettreColonne([acronyme_etab])
    Dim nom_etablissement As Variant
    Dim start As Single
    Dim finish As Single
 
    start = Timer
 
    Application.ScreenUpdating = False
 
'nettoie le nom des etablissements provenant du LAC afin d'éviter d'avoir 2 onglets
 
    Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInSheet("R_MoulinetteAValider")).Select
    Selection.Replace What:=Chr(47), Replacement:=Chr(32)
    Selection.Replace What:=Chr(92), Replacement:=Chr(32)
    Selection.Replace What:=Chr(91), Replacement:=Chr(32)
    Selection.Replace What:=Chr(93), Replacement:=Chr(32)
    nettoyerseul
 
'détruire onglet si ré-exécution de la macro
 
    detruire_onglet_etablissement
 
'création des feuilles selon le nom des etablissement
 
    For Each nom_etablissement In Sheets("R_MoulinetteAValider").Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInColumn(LettreVoulue))
 
    x = x + 1
 
        If Cells(x + 1, [valider_etablissement].Column) = "x" Or Cells(x + 1, [valider_etablissement].Column) = "X" Then
 
                If sheetExists(nom_etablissement.value) = True Then
 
                Else
 
                    Sheets.Add.Name = nom_etablissement
                    Sheets("R_MoulinetteAValider").[ID_titre].Copy Sheets(nom_etablissement.value).Range("a1")
                    Sheets("R_MoulinetteAValider").[seq_titre].Copy Sheets(nom_etablissement.value).Range("b1")
                    Sheets("R_MoulinetteAValider").[pair_impair_titre].Copy Sheets(nom_etablissement.value).Range("c1")
                    Sheets("R_MoulinetteAValider").[etab_titre].Copy Sheets(nom_etablissement.value).Range("d1")
                    Sheets("R_MoulinetteAValider").[acronyme_etab_titre].Copy Sheets(nom_etablissement.value).Range("e1")
                    Sheets("R_MoulinetteAValider").[item_etab_moulinette_titre].Copy Sheets(nom_etablissement.value).Range("f1")
                    Sheets("R_MoulinetteAValider").[item_etab_titre].Copy Sheets(nom_etablissement.value).Range("g1")
                    Sheets("R_MoulinetteAValider").[descr_etab_titre].Copy Sheets(nom_etablissement.value).Range("h1")
                    Sheets("R_MoulinetteAValider").[couleur_etab_titre].Copy Sheets(nom_etablissement.value).Range("i1")
                    Sheets("R_MoulinetteAValider").[four_etab_titre].Copy Sheets(nom_etablissement.value).Range("j1")
                    Sheets("R_MoulinetteAValider").[fournisseur_titre].Copy Sheets(nom_etablissement.value).Range("k1")
                    Sheets("R_MoulinetteAValider").[marque_etab_titre].Copy Sheets(nom_etablissement.value).Range("l1")
                    Sheets("R_MoulinetteAValider").[cat_etab_titre].Copy Sheets(nom_etablissement.value).Range("m1")
                    Sheets("R_MoulinetteAValider").[format_contrat_titre].Copy Sheets(nom_etablissement.value).Range("n1")
                    Sheets("R_MoulinetteAValider").[qte_an_titre].Copy Sheets(nom_etablissement.value).Range("o1")
                    Sheets("R_MoulinetteAValider").[prix_contrat_titre].Copy Sheets(nom_etablissement.value).Range("p1")
                    Sheets("R_MoulinetteAValider").[valider_etablissement_titre].Copy Sheets(nom_etablissement.value).Range("q1")
                    Sheets("R_MoulinetteAValider").[commentaire_etablissement_titre].Copy Sheets(nom_etablissement.value).Range("r1")
                    Sheets("R_MoulinetteAValider").[commentaire_etablissement_titre].Copy Sheets(nom_etablissement.value).Range("s1")
 
                     Range("s1").value = "Reponse de l'etablissement"
                     Columns("a:C").ColumnWidth = 6.11
                     Columns("D").ColumnWidth = 8.33
                     Columns("E").ColumnWidth = 15.78
                     Columns("F").ColumnWidth = 11.89
                     Columns("G").ColumnWidth = 15.78
                     Columns("H").ColumnWidth = 40
                     Columns("I:P").ColumnWidth = 15.78
                     Columns("Q").ColumnWidth = 11.89
                     Columns("R:U").ColumnWidth = 40
 
                     Range("a2").Activate
 
                End If
 
 'on copie les données dans la feuille correspondantes
 
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [ID].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 1)
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [seq].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 2)
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [pair_impair].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 3)
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [etab].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 4)
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [acronyme_etab].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 5)
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [item_etab_moulinette].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 6)
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [item_etab].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 7)
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [descr_etab].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 8)
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [couleur_etab].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 9)
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [fourn_etab].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 10)
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [Fournisseur].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 11)
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [marque_etab].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 12)
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [cat_etab].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 13)
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [format_contrat].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 14)
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [qte_an].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 15)
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [prix_contrat].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 16)
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [valider_etablissement].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 17)
                    Sheets("R_MoulinetteAValider").Cells(x + 1, [commentaire_etablissement].Column).Copy Sheets(nom_etablissement.value).Cells(x + 1, 18)
 
'on supprime les lignes vides si bien sur les feuilles ont été créés
 
                    Sheets(nom_etablissement.value).Select
                    Range("A2").EntireRow.Insert
                    Sheets(nom_etablissement.value).Range("b1:B" & LastLignUsedInColumn("B")).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                    With ActiveSheet.Tab
                        .ThemeColor = xlThemeColorAccent3
                        .TintAndShade = 0.399975585192419
                    End With
        End If
 
    Sheets("R_MoulinetteAValider").Select
 
    Next nom_etablissement
 
finish = Timer
 
MsgBox "durée du traitement: " & finish - start & " secondes"
 
Exit Sub
 
errorhandler:
MsgBox "Erreur d'exécution, la procédure va se terminer !", vbCritical
 
End Sub

Voici le code que j'utilise présentement qui est mieux que l'originale mais qui n'est pas à 100% à mon goût. Je continue dans la première section de nourrir mon tableau à l'aide du copy étant donné que je veux garder la mise en forme de la ligne de titre. Dans la partie auquel je bâtis les informations de la feuille, j'utilise une boucle qui est mieux mais qui n'est pas optimale.

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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
Sub genere_onglets_etablissement()
 
    On Error GoTo errorhandler:
 
    Dim x As Long
 
    Dim LettreVoulue As String
    LettreVoulue = TrouveLettreColonne([acronyme_etab])
    Dim nom_etablissement As Variant
    Dim start As Single
    Dim finish As Single
 
    Dim tableau1() As Variant
    Dim tableau2() As Variant
    Dim tableau3() As Variant
    Dim tableau4() As Variant
    Dim tableau5() As Variant
    Dim tableau6() As Variant
    Dim tableau7() As Variant
    Dim tableau8() As Variant
    Dim tableau9() As Variant
    Dim tableau10() As Variant
    Dim tableau11() As Variant
    Dim tableau12() As Variant
    Dim tableau13() As Variant
    Dim tableau14() As Variant
    Dim tableau15() As Variant
    Dim tableau16() As Variant
    Dim tableau17() As Variant
    Dim tableau18() As Variant
 
 
 
start = Timer
 
    Application.ScreenUpdating = False
 
 
'mettre les cellules voulues dans le tableau
        Sheets("R_MoulinetteAValider").Activate
 
       tableau1() = Range(TrouveLettreColonne([ID_titre]) & 2, TrouveLettreColonne([ID_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau2() = Range(TrouveLettreColonne([seq_titre]) & 2, TrouveLettreColonne([seq_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau3() = Range(TrouveLettreColonne([pair_impair_titre]) & 2, TrouveLettreColonne([pair_impair_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau4() = Range(TrouveLettreColonne([etab_titre]) & 2, TrouveLettreColonne([etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau5() = Range(TrouveLettreColonne([acronyme_etab_titre]) & 2, TrouveLettreColonne([acronyme_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau6() = Range(TrouveLettreColonne([item_etab_moulinette_titre]) & 2, TrouveLettreColonne([item_etab_moulinette_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau7() = Range(TrouveLettreColonne([item_etab_titre]) & 2, TrouveLettreColonne([item_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau8() = Range(TrouveLettreColonne([descr_etab_titre]) & 2, TrouveLettreColonne([descr_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau9() = Range(TrouveLettreColonne([couleur_etab_titre]) & 2, TrouveLettreColonne([couleur_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau10() = Range(TrouveLettreColonne([four_etab_titre]) & 2, TrouveLettreColonne([four_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau11() = Range(TrouveLettreColonne([fournisseur_titre]) & 2, TrouveLettreColonne([fournisseur_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau12() = Range(TrouveLettreColonne([marque_etab_titre]) & 2, TrouveLettreColonne([marque_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau13() = Range(TrouveLettreColonne([cat_etab_titre]) & 2, TrouveLettreColonne([cat_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau14() = Range(TrouveLettreColonne([format_contrat_titre]) & 2, TrouveLettreColonne([format_contrat_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau15() = Range(TrouveLettreColonne([qte_an_titre]) & 2, TrouveLettreColonne([qte_an_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau16() = Range(TrouveLettreColonne([prix_contrat_titre]) & 2, TrouveLettreColonne([prix_contrat_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau17() = Range(TrouveLettreColonne([valider_etablissement_titre]) & 2, TrouveLettreColonne([valider_etablissement_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau18() = Range(TrouveLettreColonne([commentaire_etablissement_titre]) & 2, TrouveLettreColonne([commentaire_etablissement_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
 
 
 
 
 
'nettoie le nom des etablissements provenant du LAC afin d'éviter d'avoir 2 onglets
 
 
Worksheets("R_MoulinetteAValider").Activate
 
    Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInSheet("R_MoulinetteAValider")).Select
    Selection.Replace What:=Chr(47), Replacement:=Chr(32)
    Selection.Replace What:=Chr(92), Replacement:=Chr(32)
    Selection.Replace What:=Chr(91), Replacement:=Chr(32)
    Selection.Replace What:=Chr(93), Replacement:=Chr(32)
    nettoyerseul
 
'détruire onglet si ré-exécution de la macro
 
    detruire_onglet_etablissement
 
'création des feuilles selon le nom des etablissement
 
    For Each nom_etablissement In Sheets("R_MoulinetteAValider").Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInColumn(LettreVoulue))
 
    x = x + 1
 
        If Cells(x + 1, [valider_etablissement].Column) = "x" Or Cells(x + 1, [valider_etablissement].Column) = "X" Then
 
                If sheetExists(nom_etablissement.value) = True Then
 
                Else
 
                    Sheets.Add.Name = nom_etablissement
                    Sheets("R_MoulinetteAValider").[ID_titre].Copy Sheets(nom_etablissement.value).Range("a1")
                    Sheets("R_MoulinetteAValider").[seq_titre].Copy Sheets(nom_etablissement.value).Range("b1")
                    Sheets("R_MoulinetteAValider").[pair_impair_titre].Copy Sheets(nom_etablissement.value).Range("c1")
                    Sheets("R_MoulinetteAValider").[etab_titre].Copy Sheets(nom_etablissement.value).Range("d1")
                    Sheets("R_MoulinetteAValider").[acronyme_etab_titre].Copy Sheets(nom_etablissement.value).Range("e1")
                    Sheets("R_MoulinetteAValider").[item_etab_moulinette_titre].Copy Sheets(nom_etablissement.value).Range("f1")
                    Sheets("R_MoulinetteAValider").[item_etab_titre].Copy Sheets(nom_etablissement.value).Range("g1")
                    Sheets("R_MoulinetteAValider").[descr_etab_titre].Copy Sheets(nom_etablissement.value).Range("h1")
                    Sheets("R_MoulinetteAValider").[couleur_etab_titre].Copy Sheets(nom_etablissement.value).Range("i1")
                    Sheets("R_MoulinetteAValider").[four_etab_titre].Copy Sheets(nom_etablissement.value).Range("j1")
                    Sheets("R_MoulinetteAValider").[fournisseur_titre].Copy Sheets(nom_etablissement.value).Range("k1")
                    Sheets("R_MoulinetteAValider").[marque_etab_titre].Copy Sheets(nom_etablissement.value).Range("l1")
                    Sheets("R_MoulinetteAValider").[cat_etab_titre].Copy Sheets(nom_etablissement.value).Range("m1")
                    Sheets("R_MoulinetteAValider").[format_contrat_titre].Copy Sheets(nom_etablissement.value).Range("n1")
                    Sheets("R_MoulinetteAValider").[qte_an_titre].Copy Sheets(nom_etablissement.value).Range("o1")
                    Sheets("R_MoulinetteAValider").[prix_contrat_titre].Copy Sheets(nom_etablissement.value).Range("p1")
                    Sheets("R_MoulinetteAValider").[valider_etablissement_titre].Copy Sheets(nom_etablissement.value).Range("q1")
                    Sheets("R_MoulinetteAValider").[commentaire_etablissement_titre].Copy Sheets(nom_etablissement.value).Range("r1")
                    Sheets("R_MoulinetteAValider").[commentaire_etablissement_titre].Copy Sheets(nom_etablissement.value).Range("s1")
 
                     Range("s1").value = "Reponse de l'etablissement"
                     Columns("a:C").ColumnWidth = 6.11
                     Columns("D").ColumnWidth = 8.33
                     Columns("E").ColumnWidth = 15.78
                     Columns("F").ColumnWidth = 11.89
                     Columns("G").ColumnWidth = 15.78
                     Columns("H").ColumnWidth = 40
                     Columns("I:P").ColumnWidth = 15.78
                     Columns("Q").ColumnWidth = 11.89
                     Columns("R:U").ColumnWidth = 40
 
                     Range("a2").Activate
 
                End If
 
 'on copie les données dans la feuille correspondantes
 
                    Sheets(nom_etablissement.value).Cells(x + 1, 1) = tableau1(x, 1)
                    Sheets(nom_etablissement.value).Cells(x + 1, 2) = tableau2(x, 1)
                    Sheets(nom_etablissement.value).Cells(x + 1, 3) = tableau3(x, 1)
                    Sheets(nom_etablissement.value).Cells(x + 1, 4) = tableau4(x, 1)
                    Sheets(nom_etablissement.value).Cells(x + 1, 5) = tableau5(x, 1)
                    Sheets(nom_etablissement.value).Cells(x + 1, 6) = tableau6(x, 1)
                    Sheets(nom_etablissement.value).Cells(x + 1, 7) = tableau7(x, 1)
                    Sheets(nom_etablissement.value).Cells(x + 1, 8) = tableau8(x, 1)
                    Sheets(nom_etablissement.value).Cells(x + 1, 9) = tableau9(x, 1)
                    Sheets(nom_etablissement.value).Cells(x + 1, 10) = tableau10(x, 1)
                    Sheets(nom_etablissement.value).Cells(x + 1, 11) = tableau11(x, 1)
                    Sheets(nom_etablissement.value).Cells(x + 1, 12) = tableau12(x, 1)
                    Sheets(nom_etablissement.value).Cells(x + 1, 13) = tableau13(x, 1)
                    Sheets(nom_etablissement.value).Cells(x + 1, 14) = tableau14(x, 1)
                    Sheets(nom_etablissement.value).Cells(x + 1, 15) = tableau15(x, 1)
                    Sheets(nom_etablissement.value).Cells(x + 1, 16) = tableau16(x, 1)
                    Sheets(nom_etablissement.value).Cells(x + 1, 17) = tableau17(x, 1)
                    Sheets(nom_etablissement.value).Cells(x + 1, 18) = tableau18(x, 1)
 
 
 
'on supprime les lignes vides si bien sur les feuilles ont été créés
 
                    Sheets(nom_etablissement.value).Select
                    Range("A2").EntireRow.Insert
                    Sheets(nom_etablissement.value).Range("b1:B" & LastLignUsedInColumn("B")).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                    With ActiveSheet.Tab
                        .ThemeColor = xlThemeColorAccent3
                        .TintAndShade = 0.399975585192419
                    End With
        End If
 
    Sheets("R_MoulinetteAValider").Select
 
    Next nom_etablissement
 
finish = Timer
 
MsgBox "durée du traitement: " & finish - start & " secondes"
 
Exit Sub
 
errorhandler:
MsgBox "Erreur d'exécution, la procédure va se terminer !", vbCritical
 
 
Erase tableau1
Erase tableau2
Erase tableau3
Erase tableau4
Erase tableau5
Erase tableau6
Erase tableau7
Erase tableau8
Erase tableau9
Erase tableau10
Erase tableau11
Erase tableau12
Erase tableau13
Erase tableau14
Erase tableau15
Erase tableau16
Erase tableau17
Erase tableau18
 
 
End Sub

Voici le code en cours de progrès. Je tente de remplacer la partie de la seconde boucle afin que ce sois plus qu'opimale. J'arrive donc avec mon resultat mais pas bien placé

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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
Sub genere_onglets_etablissement_test7()
 
'    On Error GoTo errorhandler:
 
    Dim x As Long
 
    Dim LettreVoulue As String
    LettreVoulue = TrouveLettreColonne([acronyme_etab])
    Dim nom_etablissement As Variant
    Dim start As Single
    Dim finish As Single
 
    Dim tableau1() As Variant
    Dim tableau2() As Variant
    Dim tableau3() As Variant
    Dim tableau4() As Variant
    Dim tableau5() As Variant
    Dim tableau6() As Variant
    Dim tableau7() As Variant
    Dim tableau8() As Variant
    Dim tableau9() As Variant
    Dim tableau10() As Variant
    Dim tableau11() As Variant
    Dim tableau12() As Variant
    Dim tableau13() As Variant
    Dim tableau14() As Variant
    Dim tableau15() As Variant
    Dim tableau16() As Variant
    Dim tableau17() As Variant
    Dim tableau18() As Variant
 
    Dim tableau_reponse As Variant
 
start = Timer
 
    Application.ScreenUpdating = False
 
 
'mettre les cellules voulues dans le tableau
        Sheets("R_MoulinetteAValider").Activate
 
       tableau1() = Range(TrouveLettreColonne([ID_titre]) & 2, TrouveLettreColonne([ID_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau2() = Range(TrouveLettreColonne([seq_titre]) & 2, TrouveLettreColonne([seq_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau3() = Range(TrouveLettreColonne([pair_impair_titre]) & 2, TrouveLettreColonne([pair_impair_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau4() = Range(TrouveLettreColonne([etab_titre]) & 2, TrouveLettreColonne([etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau5() = Range(TrouveLettreColonne([acronyme_etab_titre]) & 2, TrouveLettreColonne([acronyme_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau6() = Range(TrouveLettreColonne([item_etab_moulinette_titre]) & 2, TrouveLettreColonne([item_etab_moulinette_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau7() = Range(TrouveLettreColonne([item_etab_titre]) & 2, TrouveLettreColonne([item_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau8() = Range(TrouveLettreColonne([descr_etab_titre]) & 2, TrouveLettreColonne([descr_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau9() = Range(TrouveLettreColonne([couleur_etab_titre]) & 2, TrouveLettreColonne([couleur_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau10() = Range(TrouveLettreColonne([four_etab_titre]) & 2, TrouveLettreColonne([four_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau11() = Range(TrouveLettreColonne([fournisseur_titre]) & 2, TrouveLettreColonne([fournisseur_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau12() = Range(TrouveLettreColonne([marque_etab_titre]) & 2, TrouveLettreColonne([marque_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau13() = Range(TrouveLettreColonne([cat_etab_titre]) & 2, TrouveLettreColonne([cat_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau14() = Range(TrouveLettreColonne([format_contrat_titre]) & 2, TrouveLettreColonne([format_contrat_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau15() = Range(TrouveLettreColonne([qte_an_titre]) & 2, TrouveLettreColonne([qte_an_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau16() = Range(TrouveLettreColonne([prix_contrat_titre]) & 2, TrouveLettreColonne([prix_contrat_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau17() = Range(TrouveLettreColonne([valider_etablissement_titre]) & 2, TrouveLettreColonne([valider_etablissement_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau18() = Range(TrouveLettreColonne([commentaire_etablissement_titre]) & 2, TrouveLettreColonne([commentaire_etablissement_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
 
 
 
 
 
'nettoie le nom des etablissements provenant du LAC afin d'éviter d'avoir 2 onglets
 
 
Worksheets("R_MoulinetteAValider").Activate
 
    Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInSheet("R_MoulinetteAValider")).Select
    Selection.Replace What:=Chr(47), Replacement:=Chr(32)
    Selection.Replace What:=Chr(92), Replacement:=Chr(32)
    Selection.Replace What:=Chr(91), Replacement:=Chr(32)
    Selection.Replace What:=Chr(93), Replacement:=Chr(32)
    nettoyerseul
 
'détruire onglet si ré-exécution de la macro
 
    detruire_onglet_etablissement
 
'création des feuilles selon le nom des etablissement
 
    For Each nom_etablissement In Sheets("R_MoulinetteAValider").Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInColumn(LettreVoulue))
 
    x = x + 1
 
        If Cells(x + 1, [valider_etablissement].Column) = "x" Or Cells(x + 1, [valider_etablissement].Column) = "X" Then
 
                If sheetExists(nom_etablissement.value) = True Then
 
                Else
 
                    Sheets.Add.Name = nom_etablissement
                    Sheets("R_MoulinetteAValider").[ID_titre].Copy Sheets(nom_etablissement.value).Range("a1")
                    Sheets("R_MoulinetteAValider").[seq_titre].Copy Sheets(nom_etablissement.value).Range("b1")
                    Sheets("R_MoulinetteAValider").[pair_impair_titre].Copy Sheets(nom_etablissement.value).Range("c1")
                    Sheets("R_MoulinetteAValider").[etab_titre].Copy Sheets(nom_etablissement.value).Range("d1")
                    Sheets("R_MoulinetteAValider").[acronyme_etab_titre].Copy Sheets(nom_etablissement.value).Range("e1")
                    Sheets("R_MoulinetteAValider").[item_etab_moulinette_titre].Copy Sheets(nom_etablissement.value).Range("f1")
                    Sheets("R_MoulinetteAValider").[item_etab_titre].Copy Sheets(nom_etablissement.value).Range("g1")
                    Sheets("R_MoulinetteAValider").[descr_etab_titre].Copy Sheets(nom_etablissement.value).Range("h1")
                    Sheets("R_MoulinetteAValider").[couleur_etab_titre].Copy Sheets(nom_etablissement.value).Range("i1")
                    Sheets("R_MoulinetteAValider").[four_etab_titre].Copy Sheets(nom_etablissement.value).Range("j1")
                    Sheets("R_MoulinetteAValider").[fournisseur_titre].Copy Sheets(nom_etablissement.value).Range("k1")
                    Sheets("R_MoulinetteAValider").[marque_etab_titre].Copy Sheets(nom_etablissement.value).Range("l1")
                    Sheets("R_MoulinetteAValider").[cat_etab_titre].Copy Sheets(nom_etablissement.value).Range("m1")
                    Sheets("R_MoulinetteAValider").[format_contrat_titre].Copy Sheets(nom_etablissement.value).Range("n1")
                    Sheets("R_MoulinetteAValider").[qte_an_titre].Copy Sheets(nom_etablissement.value).Range("o1")
                    Sheets("R_MoulinetteAValider").[prix_contrat_titre].Copy Sheets(nom_etablissement.value).Range("p1")
                    Sheets("R_MoulinetteAValider").[valider_etablissement_titre].Copy Sheets(nom_etablissement.value).Range("q1")
                    Sheets("R_MoulinetteAValider").[commentaire_etablissement_titre].Copy Sheets(nom_etablissement.value).Range("r1")
                    Sheets("R_MoulinetteAValider").[commentaire_etablissement_titre].Copy Sheets(nom_etablissement.value).Range("s1")
 
                     Range("s1").value = "Reponse de l'etablissement"
                     Columns("a:C").ColumnWidth = 6.11
                     Columns("D").ColumnWidth = 8.33
                     Columns("E").ColumnWidth = 15.78
                     Columns("F").ColumnWidth = 11.89
                     Columns("G").ColumnWidth = 15.78
                     Columns("H").ColumnWidth = 40
                     Columns("I:P").ColumnWidth = 15.78
                     Columns("Q").ColumnWidth = 11.89
                     Columns("R:U").ColumnWidth = 40
 
                     Range("a2").Activate
 
                End If
 
 'on copie les données dans la feuille correspondantes
 
 
 
tableau_reponse = Array(tableau1(x, 1), tableau2(x, 1), tableau3(x, 1), tableau4(x, 1), tableau5(x, 1), _
                  tableau6(x, 1), tableau7(x, 1), tableau8(x, 1), tableau9(x, 1), tableau10(x, 1), _
                  tableau11(x, 1), tableau12(x, 1), tableau13(x, 1), tableau14(x, 1), tableau15(x, 1), _
                  tableau16(x, 1), tableau17(x, 1), tableau18(x, 1))
 
 
 
 
'Debug.Print Join(tableau_reponse, ";")
'Sheets(nom_etablissement.value).Range("a" & x + 1).Resize(UBound(tableau_reponse) + 1, 1) = Application.Transpose(tableau_reponse)
 
 
 
 
 
'on supprime les lignes vides si bien sur les feuilles ont été créés
 
                    Sheets(nom_etablissement.value).Select
                    Range("A2").EntireRow.Insert
                    Sheets(nom_etablissement.value).Range("b1:B" & LastLignUsedInColumn("B") + 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                    With ActiveSheet.Tab
                        .ThemeColor = xlThemeColorAccent3
                        .TintAndShade = 0.399975585192419
                    End With
        End If
 
    Sheets("R_MoulinetteAValider").Select
 
    Next nom_etablissement
 
finish = Timer
 
MsgBox "durée du traitement: " & finish - start & " secondes"
 
Exit Sub
 
errorhandler:
MsgBox "Erreur d'exécution, la procédure va se terminer !", vbCritical
 
 
Erase tableau1
Erase tableau2
Erase tableau3
Erase tableau4
Erase tableau5
Erase tableau6
Erase tableau7
Erase tableau8
Erase tableau9
Erase tableau10
Erase tableau11
Erase tableau12
Erase tableau13
Erase tableau14
Erase tableau15
Erase tableau16
Erase tableau17
Erase tableau18
Erase tableau_reponse
 
 
End Sub

DOnc si je me fit a la "recette" de RyuAutodidacte

J'ai mon

• l'ensemble de ta plage de tes données dans un Range

et

• une variable tableau qui contient la plage de tes données (via le range)

Avec cette partie de 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
tableau1() = Range(TrouveLettreColonne([ID_titre]) & 2, TrouveLettreColonne([ID_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau2() = Range(TrouveLettreColonne([seq_titre]) & 2, TrouveLettreColonne([seq_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau3() = Range(TrouveLettreColonne([pair_impair_titre]) & 2, TrouveLettreColonne([pair_impair_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau4() = Range(TrouveLettreColonne([etab_titre]) & 2, TrouveLettreColonne([etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau5() = Range(TrouveLettreColonne([acronyme_etab_titre]) & 2, TrouveLettreColonne([acronyme_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau6() = Range(TrouveLettreColonne([item_etab_moulinette_titre]) & 2, TrouveLettreColonne([item_etab_moulinette_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau7() = Range(TrouveLettreColonne([item_etab_titre]) & 2, TrouveLettreColonne([item_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau8() = Range(TrouveLettreColonne([descr_etab_titre]) & 2, TrouveLettreColonne([descr_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau9() = Range(TrouveLettreColonne([couleur_etab_titre]) & 2, TrouveLettreColonne([couleur_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau10() = Range(TrouveLettreColonne([four_etab_titre]) & 2, TrouveLettreColonne([four_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau11() = Range(TrouveLettreColonne([fournisseur_titre]) & 2, TrouveLettreColonne([fournisseur_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau12() = Range(TrouveLettreColonne([marque_etab_titre]) & 2, TrouveLettreColonne([marque_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau13() = Range(TrouveLettreColonne([cat_etab_titre]) & 2, TrouveLettreColonne([cat_etab_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau14() = Range(TrouveLettreColonne([format_contrat_titre]) & 2, TrouveLettreColonne([format_contrat_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau15() = Range(TrouveLettreColonne([qte_an_titre]) & 2, TrouveLettreColonne([qte_an_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau16() = Range(TrouveLettreColonne([prix_contrat_titre]) & 2, TrouveLettreColonne([prix_contrat_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau17() = Range(TrouveLettreColonne([valider_etablissement_titre]) & 2, TrouveLettreColonne([valider_etablissement_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))
       tableau18() = Range(TrouveLettreColonne([commentaire_etablissement_titre]) & 2, TrouveLettreColonne([commentaire_etablissement_titre]) & LastLignUsedInSheet("R_MoulinetteAValider"))

et

Code :

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

1
2
3
4
tableau_reponse = Array(tableau1(x, 1), tableau2(x, 1), tableau3(x, 1), tableau4(x, 1), tableau5(x, 1), _
                  tableau6(x, 1), tableau7(x, 1), tableau8(x, 1), tableau9(x, 1), tableau10(x, 1), _
                  tableau11(x, 1), tableau12(x, 1), tableau13(x, 1), tableau14(x, 1), tableau15(x, 1), _
                  tableau16(x, 1), tableau17(x, 1), tableau18(x, 1))

Étant donné que mes données dans tableau1 à 18 ne sont pas contigue

Pour la partie

• une autre variable tableau pour transposer tes données et qui sera dimensionnée via un CountIf sur la colonne ou se trouve les X et le nombre de colonne de ton nouveau tableau

J'utilise déjà un X dans la partie

Code :

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

1
2
3
4
5
For Each nom_etablissement In Sheets("R_MoulinetteAValider").Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInColumn(LettreVoulue))
 
    x = x + 1
 
        If Cells(x + 1, [valider_etablissement].Column) = "x" Or Cells(x + 1, [valider_etablissement].Column) = "X" Then

de mon code. Effectivement le X n'est pas dans le array mais il positionne le tout a la bonne position a cause de cette boucle qui incrémente mon X

JE vais donc continuer la lecture sur le poste en lien !!!

Également, je n'Avais pas pensez au filte élaboré. Ca va etre une première tentative au niveau de VBA, mais a savoir si le tout sera plus vite que la "transposition"

merci mille fois a vous pour votre temps et aides.

**jpvba** · 03/10/2018, 17h17

J'ai terminé la lecture du poste en lien de Ryu et c'est très intéressant mais ma réponse manquante cherché ne me saute pas aux yeux, malheureusement

Pour l'idée de Philippe, je ne crois pas finalement que ce sois une idée possible pour mon cas. Il faudrait que je détruit des colonnes par la suite après avoir exporter les données. Je risque d'avoir un délai d'exécution plus grand que ce que j'ai a présent. J'avais également fais un teste de copier entièrement les données dans les onglets créés correspondant au nom d'établissement et supprimer les données par la suite mais le tout étais déjà plus lent que ce que j'avais. Je presume que ce sera le meme cas.

Je vais donc tenter de re-re lire le poste de Ryu

a plus !!!!

**RyuAutodidacte** · 03/10/2018, 18h09

Bonjour,

Je pense que pour avancer, se serait bien de nous fournir un fichier xlsx avec de fausses données
représentant exactement la réalité (15 à 20 lignes suffisent), avec un onglet des données au départ et un onglet pour le résultat final.
Tout est important : y a t il des formules ou pas, des mises en forme ou pas, etc …
Mettre des commentaires sur le côté des données si nécessaire

**jpvba** · 03/10/2018, 19h45

Bonjour Ryu,

JE vais joindre 2 fichiers, sois un avec des donnés bidon (fichier pour test.xlsx) et l'autre fichier avec le depart et ce qu'il faut arriver (fichier debut resultat.xlsx). Dans ce dernier tu remarqueras que les onglets des résultats sont en vert.

Il n'y a pas de formule dans mon fichier mais des mises en page pour l'entête

en te remerciant milles fois !!!

vraiment beaucoup apprécié !!!

**jpvba** · 03/10/2018, 19h51

A titre indicatif, je te joins des fonction qui sont utilisé dans mon code

Code :

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

1
2
3
4
5
Public Function TrouveLettreColonne(ByVal ColonneCherche As Range)
 
TrouveLettreColonne = Split(Columns(ColonneCherche.Column).Address(ColumnAbsolute:=False), ":")(1)
 
End Function

Code :

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

1
2
3
4
5
Public Function LastLignUsedInSheet(NomOnglet As String)
 
    LastLignUsedInSheet = Worksheets(NomOnglet).UsedRange.Rows.Count
 
End Function

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
Sub detruire_onglet_etablissement()
 
 
    Dim LettreVoulue As String
    LettreVoulue = TrouveLettreColonne([acronyme_etab])
    Dim nom_etablissement As Variant
 
    Application.ScreenUpdating = False
 
    Sheets("R_MoulinetteAValider").Activate
 
 
    For Each nom_etablissement In Sheets("R_MoulinetteAValider").Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInColumn(LettreVoulue))
 
 
 
                If sheetExists(nom_etablissement.value) = False Then
 
 
                Else
 
                    Application.DisplayAlerts = False
                    Sheets(nom_etablissement.value).Delete
                    Application.DisplayAlerts = True
                End If
 
 
 
 
    Next nom_etablissement
 
 
End Sub

Code :

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

1
2
3
4
5
6
7
8
9
10
Sub nettoyerseul()
 
    Dim sourceCell As Variant
 
    For Each sourceCell In Selection
        sourceCell.value = StripAccent(UCase(CleanTrim(sourceCell.value)))
 
    Next sourceCell
 
End Sub

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
Function StripAccent(thestring As String)
 
    Dim a As String * 1
    Dim b As String * 1
    Dim i As Integer
    Const AccChars = "ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ"
    Const RegChars = "SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy"
 
    For i = 1 To Len(AccChars)
        a = Mid(AccChars, i, 1)
        b = Mid(RegChars, i, 1)
        thestring = Replace(thestring, a, b)
 
    Next
 
    StripAccent = thestring
 
End Function

**Philippe Tulliez** · 03/10/2018, 20h21

Bonjour,

Pour l'idée de Philippe, je ne crois pas finalement que ce sois une idée possible pour mon cas

J'ai regardé ton fichier et je suis désolé de te décevoir mais la solution que j'ai proposée avec la méthode AdvancedFilter est exactement appropriée pour ton cas sauf qu'il ne m'avait pas semblé que tu avais évoqué qu'il fallait "splitter" les données sur plusieurs onglets en fonction d'une liste de données contenue dans une colonne mais Oh miracle cela aussi la méthode AdvancedFilter peut également le faire. voir cette discussion en cours actuellement.

Il faudrait que je détruit des colonnes par la suite après avoir exporter les données

Où as-tu lu qu'il fallait supprimer des colonnes ?
J'ai pourtant afficher l'image prouvant le contraire avec EN PLUS le code qui le fait ?

C'est à vous dégoûter de répondre. Cela donne l'impression d'écrire dans le vide

**jpvba** · 03/10/2018, 20h33

Merci monsieur Tulliez pour votre réponse.

Je vais donc également voir cette option.

C'Est en me fiant seulement au tutoriel mis en lien que j'ai déduis la destruction de colonne. Je m’aperçois donc que ce fait est erroné. Lorsque j'ai vu il y a 16 ans le filtre élaboré nous n'avions surement pas été non plus en profondeur du sujet. De mémoire on devais avoir les même critère et résultats. Je vois que je suis dans le champs ... Pour l'imprime écran je vois que le critère est das le fichier et non dans le code ... j'ai dédui que je devais absolument en inscrire un dans la feuille en question, ce que je voudrais éviter

Désolé de vous avoir offusqué et non je lis vos commentaires et suggestions. Il y a beaucoup de matière a digéré d'un coup et je suis désolé si j'ai pu vous brusqué.

**RyuAutodidacte** · 04/10/2018, 03h41

Bonjour,

Je te laisse bucher par toi même pour comprendre le code, tu peux abuser de la touche F1 pour l'aide VBA et de la Faq

A utiliser pour test dans ton fichier "fichier debut resultat.xlsx" (garde que l'onglet "depart" et vire les autres)
PS : Dans le principe j'utilise une Collection pour récupérer les lignes pour chaque onglets via un un tableau VA dont je me sert aussi pour récupérer les données
Après je boucle sur la collection pour récupérer les infos nécessaire (onglets et lignes des données) - les données sont transférées dans un tableau VB via un procéder que te laisse découvrir

1 code et 2 functions qui vont avec :

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
Sub CritArray()
Dim Col As Variant, DL As Long, Plage As Range, VA As Variant, i As Long, NewColl As New Collection, NC As Variant, Lig As Variant, VB As Variant, DimTab As Integer, NomFeuille As String
Const Col_Acro As Byte = 5, Col_X As Byte = 29
 
    Col = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 29, 30)
    With Sheets("depart")
        DL = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set Plage = .Range("A2:AD" & DL)
        VA = Plage
        Set Plage = Nothing
Application.ScreenUpdating = False
        On Error Resume Next
        For i = 1 To UBound(VA)
            If UCase(VA(i, Col_X)) = "X" Then
                NewColl.Add UCase(VA(i, Col_Acro)) & "|" & i, UCase(VA(i, Col_Acro))
                If Err Then
                    Err.Clear
                    Ligne = NewColl(UCase(VA(i, Col_Acro)))
                    NewColl.Remove UCase(VA(i, Col_Acro))
                    NewColl.Add Ligne & "|" & i, UCase(VA(i, Col_Acro))
                End If
                .Cells(i + 1, Col_X).Value = "Extraction OK"
            End If
        Next
        On Error GoTo 0
    End With
 
    For Each NC In NewColl
        NomFeuille = Mid(NC, 1, InStr(NC, "|") - 1)
        Lig = Application.Transpose(Split(NC, "|"))
        Lig = Application.Index(Lig, Evaluate("Row(2:" & UBound(Lig) & ")"))
        VB = Application.Index(VA, Lig, Col)
        DimTab = Len(NC) - Len(Replace(NC, "|", ""))
 
    If Not ExistWorkSheet(NomFeuille) Then
        Sheets.Add , Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = NomFeuille
        En_Tete NomFeuille
    End If
    With Sheets(NomFeuille)
        DL = .Cells(.Rows.Count, 1).End(xlUp)(2).Row
        If DimTab > 1 Then .Cells(DL, 1).Resize(UBound(VB), UBound(VB, 2)).Value = VB _
                    Else .Cells(DL, 1).Resize(, UBound(VB)).Value = VB
    End With
    Next
Application.ScreenUpdating = True
End Sub

Code :

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

1
2
3
Function ExistWorkSheet(FEUILLE) As Boolean ' Code Fait par Marc-L
         ExistWorkSheet = Evaluate("ISREF('" & FEUILLE & "'!A1)")
End Function

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
Function En_Tete(New_Feuil As String)
Dim Entete As Range
    With Sheets("depart")
        Set Entete = Union(.Range("A1:P1"), .Range("AC1:AD1"))
        With Entete
            With .Copy
                With Sheets(New_Feuil).Range("A1")
                .PasteSpecial Paste:=xlPasteColumnWidths
                .PasteSpecial Paste:=xlPasteFormats
                .PasteSpecial Paste:=xlPasteValues
                    With .CurrentRegion
                        With .Columns.Item(.Columns.Count)
                        .Copy
                            With .Offset(, 1)
                                .PasteSpecial Paste:=xlPasteColumnWidths:
                                .PasteSpecial Paste:=xlPasteFormats
                            End With
                            .Offset(, 1).Value = "Reponse de l'etablissement"
                        End With
                    End With
                End With
            End With
        End With
    End With
    Application.CutCopyMode = False
End Function

**Pierre Fauconnier** · 04/10/2018, 09h03

Salut.

Le code de départ pourrait déjà être rationnalisé.

Travailler avec un objet Worksheet plutôt que avec Worsksheets("...")...;
Ne pas redimensionner les columns dans la boucle mais avoir conçu cela avant;
désactiver le calcul automatique;
calculer les index de colonne hors de la boucle;
Calculer la dernière ligne (LastLignUsedInSheet(...)) hors de la boucle;
Travailler avec des tableaux structurés (au moins pour les tableaux dans lesquels on colle);
...

Bref, penser et concevoir le projet et le classeur avant la première ligne de code, et se servir du VBA pour ce qui relève de la vraie automatisation (en gros, les copier-coller) en ayant dégrossi le travail avant.

Je sais que cela ne va pas plaire à certains, mais c'est la seule façon profesionnnelle d'envisager ce traitement. Lorsque cela est réalisé, on regarde pour l'optimisation, qui est alors en général beaucoup plus simple à mettre en place

Au passage, attention avec les Application.Transpose qui foutent les dates en l'air, notamment...

**RyuAutodidacte** · 04/10/2018, 09h17

Bonjour Pierre,

Au passage, attention avec les Application.Transpose qui foutent les dates en l'air, notamment...

Cela tombe bien il n'y en a pas sur les données d'application transpose

Edit : petite modif

**Pierre Fauconnier** · 04/10/2018, 15h47

Ryu,

Essaie de comprendre la substance de mes propos...

De la réflexion, de la conception, l'utilisation des outils Excel tels que les filtres avancés et, dans 99,99% des cas, pas besoin de split et d'application.transpose et autres bazars avec des index de colonnes en dur dans le code et autres atrocités...

Revenir aux fondamentaux en comprenant la philosophie de l'outil qu'est Excel et on se passe bien souvent de masturbation intellectuelle et de code hardcodé qui plante à la moindre modif

**jpvba** · 04/10/2018, 16h30

Merci beaucoup pour vos commentaire

J'ai pas mal de pain sur la planche !!!

Si je prends l'expression de Ryu, il faut que je bûche un peux et en plus corde mon bois !!!

Je vais également essayé l'avenue de monsieur Tulliez qui est très intéressant.

merci monsieur Fauconnier.

Comme vous pouvez le constater, je prends du poil de la bête !!! La mise en terre d'y a deux semaines ma aidé a faire mon deuil ...

**RyuAutodidacte** · 04/10/2018, 16h42

Bonjour,

Si je prends l'expression de Ryu, il faut que je bûche un peux et en plus corde mon bois !!!

Désolé si c'est mal pris, mais j'ai donné pas mal d'éléments afin de pouvoir comprendre le code (cf liens)
Et c'est une bonne façon d'apprendre ; après je suis toujours là si il y a un blocage / une incompréhension dans le code …
Comme tu voulais passer par des variables tableaux …
Et il est toujours bien de décortiquer un code en l'activant via le pas à pas afin de constater ce qui se passe dans les variables locales …

Et non , il n'y a aucune masturbation intellectuelle et ce code n'est pas hardcodé et il ne plante pas …

PS : j'ai qd même passé du temps pour comprendre le principe et le fonctionnement de ce que tu voulais .…
Il peut exister plusieurs solutions pour une problématique, il faut juste choisir celle qui convient le mieux …

**Pierre Fauconnier** · 04/10/2018, 16h49

Code :

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

1
2
3
4
5
6
7
    Col = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 29, 30)
    With Sheets("depart")
        DL = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set Plage = .Range("A2:AD" & DL)
...
...
If UCase(VA(i, Col_X)) = "X" Then

Pas hardcodé? Rien que la condition (hyper simpliste dans le code que tu donnes) c'est du hardcodage

Alors qu'avec les filtres avancés, il n'y a fonctionnellement besoin d'aucun code vba et si on utilise du vba, c'est juste pour automatiser le filtre avancé...

Il y a deux cas de figure:

Soit c'est une oneshot et pas besoin de VBA, les filtres avancés Excel suffisent;
Soit ce n'est pas un oneshot et alors il est question de [I]CONCEPTION.

Si on a besoin de conception:

Dans le classeur d'analyse, on prépare le filtre avance (zone de réception des données, zone de critère formulé, formule de critère);
On y importe les données à traiter;
On applique le filtre avancé.

C'est TOUT ce qu'il y a à faire! Ca prend cinq ou six lignes de code.

**jpvba** · 04/10/2018, 16h50

Non mon cher Ryu,

Je prends ca du bon coté, je suis également d'avis qu'il faut m'aidé a comprendre que me donné tout cuit dans le bec !!!

JE dois également considéré les avenus de monsieur Tulliez,

merci beaucoup pour ta disponibilité et volonté de m'aider, c'Est plus qu'apprécié ...

Il reste toujours la barrière d'écriture qui n'identifie pas malheureusement l'intention et les sentiments dans les idées mais de mon côté je viens ici de façon positive et vois les intervention de façon positive.
Il y a également le non dit qui peut choquer la personne qui demande de l'aide et les gens qui aident ces même personnes ... mais je peut composé avec.
Également le dialecte Français qui varie d'une région et pays à l'autre. Usine a gaz est la première fois que j'attendais cette expression sur ce forum.

Je vais donc vous faire un petit coucou lorsque j'aurais testé votre code.

non je suis loin d'etre frustré mais vraiment heureux d'avoir es gens comme vous me donnant du support

amicalement JP