Compilation d'un code dans un autre bouton

Version imprimable

Voir 40 message(s) de cette discussion en une page

08/04/2013, 16h45
Matrixmax

çà a trés bien marché

Bonjour mon Prof,

J'ai bien saisi ton code ; je l'ai "compris", et je l'ai testé et çà a bien marché Merci infiniment .

Mais j'ai un soucis :

Est ce que ; quand on va faire l'importation de plusieurs fichier à la fois, la procédure sera la méme et le résultats sera appliquée sur l'enssemble .

parceque je pensais qu'on va dabord présenter le résultats finale de l'enssemble des fichier selectionné avant le trie sur une feuil séparée on appliquant la procédure sur l'enssemble des fichiers selectionnés telque celui du cas présent.

et aprés, faire le trie sur l'enssemble avant d'appliquer la mise en forme finale et exporter les résultat vers une feuil word .

Parceque enfait , la machine délivre plusieurs fichiers chacun comporte un enssemble de 32 'simple number' or on peut avoir dans un de ces fichier une référence 2.3 .... et dans un autre fichier 2.1 et donc c çà l'utilitée de laisser le trie à la phase finale .
09/04/2013, 17h42
Matrixmax
bonjour monsieur ;

J'espére que tout va bien chez toi ... !

J'attend toujours tes réponses .

Je suis actuellement bloquer en phase de faire une boucle sur une multiselection de la synthase Getopenfile name ( ,,,,,,, mutiselect True )

le probléme que je rencontre c'est le faite de garder la feuil de calcule de chacun des fichier selectionné et aussi de faire le tableau résultant de chaque fichier de la selection l'un prés de l'autre dans un troixiéme feuil.

pour par la suite faire le trie de l'enssemble

se débarrasser de voies vide ou contenant des file

et ensuite mettre la totalitée en forme afin de les exporter vers un fichier word

enfaite j'ai pu faire la multi selection on se basant sur la boucle for each
Code:

1 2 3 4 5 6 7 8 9 10 11 Lefichier = Application.GetOpenFilename(, , , , True) If IsArray(Lefichier) Then For i = LBound(FichiersAOuvrir, 1) To UBound(FichiersAOuvrir, 1) . . . . .
le code boucle sur les fichier selectionné mais j'ai pas pu extraire le résultat de chacun

j'ai essyé de faire une procédur que je fais appel à ; avant de finaliser la procédure principale pour que j'extrait le tableau de résultat
09/04/2013, 19h50
mercatog

Bonjour
C'est une obligation de répondre? Sans réponse, tu devrais avoir le réflexe que ta question n'est pas assez claire.
Ensuite, c'est une étrange manière de faire faire ton travail alors que tu n'ajoute rien. Je pense que le contraire sera le bienvenu. Tu commence et le forum corrige.

C'est une remarque que j'avais à faire.

En second lieu, ce que j'avais commencé c'est que le code importe les données d'une seul fichier, les copie avec un traitement dans une seconde feuille (après l'avoir effacé au préalable) et on arrive dans cette feuille à un tableau final C324:AI336 et on arrête là.

Si on importe un nouveau fichier, toute la 2ème feuille sera d'abord effacée ensuite le même traitement.

Est ce que tu as prévu une feuille temporaire où on va stocker les tableaux C324:AI336 de chaque fichier?

Si tu estime que tu avais compris le code

Citation:

J'ai bien saisi ton code ; je l'ai "compris", et je l'ai testé et çà a bien marché Merci infiniment .

Tu aurais pensé à ce que je viens d'écrire là.

Rusé?

preuve

Bonjour Mercatog,

pour te prouver que j'ai bien saisis ton code j'ai passer la nuit réfléchissant et essayant de rechercher la bonne solution et on passant par une disaine de maniére à faire le travail d'importer et élaborer tout les fichier selectionné ...

et pour te preuver que je suis vraiment un bon éléve tine le code :

Code:

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
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
 
 
Option Explicit
 
Const CREM As String = "Calcul Resistance + Evolut Max"    'Nom de la feuille de calcul
Const MB As String = "Mesure Bending"              'Nom de la feuille de base
'------------------------------------------------------------------------------------------
'Procédure principale
'------------------------------------------------------------------------------------------
Sub Principale()
Dim Lefichier, j As Variant
Dim WsCR As Worksheet
Dim i As Integer
Dim Tmp, TbSyn
 
Application.ScreenUpdating = False
 
 
Lefichier = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , , , True)
 
For j = LBound(Lefichier, 1) To UBound(Lefichier, 1)
If ImportData(Lefichier(j)) Then
    'Appel de Cycle 0
    Call CycleZero(WsCR)
 
    'Appel pour les autres cycles
    Tmp = WsCR.Range("C19:AI19")
 
    For i = 1 To 20
        Call CycleN(WsCR, Tmp, 8 + 17 * i, 7 + 14 * i)
    Next i
 
    Call CycleFinal(WsCR)
 
    Call Synthese(WsCR)
 
    TbSyn = WsCR.Range("C324:AI336")
    'ici on va continuer le code pour les autres traitements
    'La variable TbSyn comporte déjà les données de synthèse brutes qu'on va par la suite traiter
 
    Set WsCR = Nothing
    MsgBox "Traitement terminé", , "Confirmation"
 
Else
    MsgBox "Aucun fichier n'est sélectionné", , "Annulation"
End If
Next j
End Sub
 
'------------------------------------------------------------------------------------------
'Fonction booléenne qui est VRAI lorsque l'import a réussi
'après avoir ouvert le fichier entré en paramètre, copié toutes les donnée de la feuille 1
'dans la feuille Mesure Bending et fermeture du fichier
'------------------------------------------------------------------------------------------
Private Function ImportData(ByVal Fichier As Variant) As Boolean
Dim Wbk As Workbook
 
If Dir(Fichier) <> "" Then
    Set Wbk = Workbooks.Open(Fichier)
    With ThisWorkbook.Worksheets(MB)
        .UsedRange.Clear
        Wbk.Worksheets(1).UsedRange.Copy .Range("A1")
    End With
    Wbk.Close False
    Set Wbk = Nothing
    ImportData = True
End If
End Function
 
'------------------------------------------------------------------------------------------
'Fonction qui retourne la feuille Str
'Si la feuille Existe, on l'efface
'Sinon, on la créé et on la nomme avec le contenu de la variable Str
'------------------------------------------------------------------------------------------
Private Function CreateSheet(ByVal Str As String) As Worksheet
 
On Error Resume Next
 
On Error GoTo 0
 
Dim o As Variant
o = Worksheets.Count
 
    Set CreateSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(o))
    CreateSheet.Name = Str & o
 
End Function
 
'------------------------------------------------------------------------------------------
'Procédure qui établit le premier tableau correspondant au Cycle 0
'------------------------------------------------------------------------------------------
Private Sub CycleZero(ByRef Ws As Worksheet)
 
Set Ws = CreateSheet(CREM)
With Ws
    'On copie le tableau correspondant au Cycle 0
    Worksheets(MB).Range("A6").CurrentRegion.Copy .Range("C2")
 
    Call Moyenne(Ws, 19)
    With .Range("C4:AI5")
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .Range("C4:AI19").Borders.LineStyle = xlContinuous
End With
End Sub
 
'------------------------------------------------------------------------------------------
'Procédure qui permet de transférer les données du Cycle N
'après avoir retranché la moyenne de chaque voie du cycle 0
'Ici j'utilise une variable tableau Tb pour les calculs intermidiaires
'------------------------------------------------------------------------------------------
 
Private Sub CycleN(ByVal Ws As Worksheet, ByVal Ini, ByVal Dep As Integer, ByVal Des As Integer)
Dim i As Integer, j As Integer
Dim Moy As Double
Dim Tb
 
With Worksheets(MB)
    .Range("A" & Dep).Resize(1, 2).Copy Ws.Range("A" & Des).Resize(13, 2)
    Tb = .Range("A" & Dep + 2).Resize(14, 33)
End With
 
For j = 2 To 33
    Moy = Vale(Ini(1, j))
    For i = 1 To 13
        Tb(i, j) = Vale(Tb(i, j)) - Moy
    Next i
Next j
 
With Ws.Range("C" & Des).Resize(13, 33)
    .Value = Tb
    .Borders.LineStyle = xlContinuous
End With
 
End Sub
 
Private Function Vale(ByVal Str As String) As Double
 
Vale = Val(Replace(Str, ",", "."))
End Function
'------------------------------------------------------------------------------------------
'Procédure qui permet de transférer les données du Cycle Final
'------------------------------------------------------------------------------------------
 
Private Sub CycleFinal(ByVal Ws As Worksheet)
 
With Ws
    'On copie le tableau correspondant au Cycle 0
    Worksheets(MB).Range("A365").CurrentRegion.Copy .Range("C301")
 
    Call Moyenne(Ws, 317)
    .Range("C303:AI317").Borders.LineStyle = xlContinuous
End With
End Sub
 
'------------------------------------------------------------------------------------------
'Procédure qui permet de faire la moyenne d'un tableau de Np lignes et Nv colonnes
'à partir de la ligne Lig
'ici c'est utile pour faire la moyenne du tableau cycle 0 et cycle final
'------------------------------------------------------------------------------------------
Private Sub Moyenne(ByVal Ws As Worksheet, ByVal Lig As Integer)
 
With Ws
    With .Range("B" & Lig - 15)
        .Value = IIf(Lig = 19, "R_Ini", "R_Final")
        .Font.Bold = True
    End With
 
    'on fait la moyenne par colonne
    .Range("C" & Lig) = "Moyenne"
    With .Range("D" & Lig & ":AI" & Lig)
        .FormulaR1C1 = "=AVERAGE(R[" & -1 * 13 & "]C:R[-1]C)"
        .Value = .Value
        .NumberFormat = "0.00"
    End With
 
    'mises en forme diverses
    With .Range("C" & Lig & ":AI" & Lig)
        .Font.Bold = True
        .Interior.ColorIndex = 37
        .Borders.LineStyle = xlContinuous
    End With
End With
End Sub
 
'------------------------------------------------------------------------------------------
'Procédure qui permet de faire la synthèse des cycles en prenant pour chaque voie le max des Positions A et B
'le tableau de synthèse est écrit à partir de la ligne 323
'Pour trouver le max avec condition, j'utilise la formule excel =MAX(SI(PlageCritere=Critere;PlageCalcul;""))
'------------------------------------------------------------------------------------------
 
Private Sub Synthese(ByVal Ws As Worksheet)
 
With Ws
    .Range("C4:AI5").Copy .Range("C323")
    .Range("C325").Resize(10, 1).Formula = "=""Cycle ""&ROW()-324"
    .Range("D325").FormulaArray = "=MAX(IF($A$21:$A$299=$C325,D$21:D$299,""""))"
    .Range("D325").AutoFill .Range("D325").Resize(10, 1)
    .Range("D325").Resize(10, 1).AutoFill .Range("D325").Resize(10, 32)
    With .Range("C325").Resize(10, 33)
        .Value = .Value
        .Borders.LineStyle = xlContinuous
    End With
    .Range("C19:AI19").Copy .Range("C335")
    .Range("C335") = "R_Ini"
 
    .Range("C317:AI317").Copy .Range("C336")
    .Range("C336") = "R_Fin"
 
 
    Call TriHorizontal(.Range("D323:AI336"))
 
    .Range("D325:AI336").NumberFormat = "0.0"
End With
End Sub
 
 
Private Sub TriHorizontal(ByVal Plage As Range)
 
With Plage.Parent
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=Plage.Offset(1, 0).Resize(1, Plage.Columns.Count), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange Plage
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    .Sort.SortFields.Clear
End With
End Sub

Maintenant le Code traite l'enssemble des fichier selectionnés tu peut le tester on faisant deux copie du fichier de test on on changeons les valeur d'un tableau , je travail maintenant sur l'assemblage de l'enssemble des tableau de résultat l'unn pré de l'autre dans une feuil synthése .

Or le probléme que je rencontre c'est coment faire une selection varriable de façon à incrémenter une varriable de 32 colonne on copiant le tableau contenant dans chaque feuil de calcule autre que la premiére .

et on utilisant deux boucle embarqué :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
 
'créer feuil de synthése
 Set Synthése= ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(sheets.count))
CreateSheet.Name = Synthése
 
for i = 2 to i = sheets.count -1 
with sheet(i)
 
'copier le tableau vers la feuil de synthése dans la plage qui contient une  Varriable colonne qui incrémente à chaque fois de 32 [x + 32 ] et ligne fixe
 
end with
 
next i

Ensuite je vais mettre à jour la procédure de trie de façon à faire changer la plage de trie pour qu'il sera la totalitée des tableau et l'appliquer à sheets(synthése)

Bon , Je comprend ton point de vu , tu veux qu'a la place de prendre à chaque fois des réponse délicieuse , faire son propore plat , pouir le jour du desert .. :)

Mais je te jure que je fais un trés grand effort pour se débrouillé , c'est un défit que j'ai pris de terminer ce travail parfaitement.

J'ai résolue ce matin le probléme que j'ai eu du varriable de selection de la colonne , maintenant je collext l'enssemble des tableau de résultat dans la méme feuil ...

Tien le CODE CHef :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Private Sub synthése()
Dim i, j As Variant
Dim ColAjout As Integer
    'On ajoute une feuille au classeur
    ThisWorkbook.Sheets.Add After:=Sheets(ThisWorkbook.Sheets.Count)
    Sheets(Sheets.Count).Name = "synthése"
    'On initialise le numéro de colonne pour l'ajout
    ColAjout = 1
    'Pour chaque feuille à partir de la 2eme et jusqu'à l'avant dernière
    For i = 2 To Sheets.Count - 1
        With Sheets(i)
        If i = 2 Then
        .Range("C324:AI336").Copy ActiveSheet.Cells(1, ColAjout)
        ColAjout = ActiveSheet.Cells(1, 1).End(xlToRight).Column + 1
        Else
            'On copie la plage "D324:AI336" de chaque feuille
            'On colle cette plage dans la dernière feuille, après la dernière colonne renseignée.
            .Range("D324:AI336").Copy ActiveSheet.Cells(1, ColAjout)
            'On définit le numéro de colonne pour le prochain ajout
            ColAjout = ActiveSheet.Cells(1, 1).End(xlToRight).Column + 1
            End If
        End With
    Next i
End Sub

Si tu vois qu'il y as des amélioration à apporter je serais honorable de les avoir de ta part :) ...

Merci d'avance !!

Bonjour,

J'ai rencontré un rpobléme de IF J'ai fais une varraible Lefichier en tant que variant .

Or quand on choisis un fichier ou plusieurs la boucle fonctionne trés bien . mais si on ne choisis aucun fichier on auras un probléme d'incompatibilité de varriable parce qu'elle devient boulean .

par contradiction il bug au niveau de la ligne de la condition

Code:

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
Sub Principale()
Dim Lefichier, j As Variant
Dim WsCR As Worksheet
Dim i As Integer
Dim Tmp, TbSyn
 
Application.ScreenUpdating = False
 
Call Suprsh
 
Lefichier = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , , , True)
'bug à ce niveau
For j = LBound(Lefichier, 1) To UBound(Lefichier, 1)
If ImportData(Lefichier(j)) Then
    'Appel de Cycle 0
    Call CycleZero(WsCR)
 
    'Appel pour les autres cycles
    Tmp = WsCR.Range("C19:AI19")
 
    For i = 1 To 20
        Call CycleN(WsCR, Tmp, 8 + 17 * i, 7 + 14 * i)
    Next i
 
    Call CycleFinal(WsCR)
 
    Call Synthese(WsCR)
 
    TbSyn = WsCR.Range("C324:AI336")
    'ici on va continuer le code pour les autres traitements
    'La variable TbSyn comporte déjà les données de synthèse brutes qu'on va par la suite traiter
 
    Set WsCR = Nothing
    MsgBox "Traitement terminé", , "Confirmation"
    Call synt
Else
    MsgBox "Aucun fichier n'est sélectionné", , "Annulation"
End If
Next j
End Sub

Merci d'avance

Bonjour Matrixmax

Merci pour l'effort

Ci-joint proposition en boucle copiant les tableaux de synthèse successifs sur une feuille dédiée à ceci

Code:

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
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
Option Explicit
 
Const CREM As String = "Calcul Resistance + Evolut Max"    'Nom de la feuille de calcul
Const MB As String = "Mesure Bending"              'Nom de la feuille de base
Const SY As String = "Synthese"                    'Nom de la feuille de synthèse
'------------------------------------------------------------------------------------------
'Procédure principale
'------------------------------------------------------------------------------------------
Sub Principale()
Dim Syn As Worksheet
Dim i As Integer
Dim TbFichier
 
TbFichier = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , , , True)
If IsArray(TbFichier) Then
    Set Syn = CreateSheet(SY)
    For i = 1 To UBound(TbFichier)
        Call Traitement(TbFichier(i))
        Worksheets(CREM).Range("C2:D2").Copy Syn.Range("A1").Offset(15 * (i - 1))
        Worksheets(CREM).Range("C324:AI336").Copy Syn.Range("A2").Offset(15 * (i - 1))
    Next i
    Set Syn = Nothing
    MsgBox "Traitement terminé", , "Confirmation"
Else
    MsgBox "Aucun fichier n'est sélectionné", , "Annulation"
End If
End Sub
'------------------------------------------------------------------------------------------
'Procédure Traitement
'------------------------------------------------------------------------------------------
Sub Traitement(ByVal LeFichier As String)
Dim WsCR As Worksheet
Dim i As Integer
Dim Tmp
 
Application.ScreenUpdating = False
If ImportData(LeFichier) Then
    'Appel de Cycle 0
    Call CycleZero(WsCR)
 
    'Appel pour les autres cycles
    Tmp = WsCR.Range("C19:AI19")
 
    For i = 1 To 20
        Call CycleN(WsCR, Tmp, 8 + 17 * i, 7 + 14 * i)
    Next i
 
    Call CycleFinal(WsCR)
 
    Call TabSynthese(WsCR)
 
    Set WsCR = Nothing
End If
End Sub
 
'------------------------------------------------------------------------------------------
'Fonction booléenne qui est VRAI lorsque l'import a réussi
'après avoir ouvert le fichier entré en paramètre, copié toutes les donnée de la feuille 1
'dans la feuille Mesure Bending et fermeture du fichier
'------------------------------------------------------------------------------------------
Private Function ImportData(ByVal Fichier As String) As Boolean
Dim Wbk As Workbook
 
If Dir(Fichier) <> "" Then
    Set Wbk = Workbooks.Open(Fichier)
    With ThisWorkbook.Worksheets(MB)
        .UsedRange.Clear
        Wbk.Worksheets(1).UsedRange.Copy .Range("A1")
    End With
    Wbk.Close False
    Set Wbk = Nothing
    ImportData = True
End If
End Function
 
'------------------------------------------------------------------------------------------
'Fonction qui retourne la feuille Str
'Si la feuille Existe, on l'efface
'Sinon, on la créé et on la nomme avec le contenu de la variable Str
'------------------------------------------------------------------------------------------
Private Function CreateSheet(ByVal Str As String) As Worksheet
 
On Error Resume Next
Set CreateSheet = ThisWorkbook.Worksheets(Str)
On Error GoTo 0
 
'Si la feuille existe, on l'efface
If Not CreateSheet Is Nothing Then
    CreateSheet.UsedRange.Clear
    'Sinon, on ajoute une feuille vierge qu'on renomme
Else
    Set CreateSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(1))
    CreateSheet.Name = Str
End If
End Function
 
'------------------------------------------------------------------------------------------
'Procédure qui établit le premier tableau correspondant au Cycle 0
'------------------------------------------------------------------------------------------
Private Sub CycleZero(ByRef Ws As Worksheet)
 
Set Ws = CreateSheet(CREM)
With Ws
    'On copie le tableau correspondant au Cycle 0
    Worksheets(MB).Range("A6").CurrentRegion.Copy .Range("C2")
 
    Call Moyenne(Ws, 19)
    With .Range("C4:AI5")
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .Range("C4:AI19").Borders.LineStyle = xlContinuous
End With
End Sub
 
'------------------------------------------------------------------------------------------
'Procédure qui permet de transférer les données du Cycle N
'après avoir retranché la moyenne de chaque voie du cycle 0
'Ici j'utilise une variable tableau Tb pour les calculs intermidiaires
'------------------------------------------------------------------------------------------
 
Private Sub CycleN(ByVal Ws As Worksheet, ByVal Ini, ByVal Dep As Integer, ByVal Des As Integer)
Dim i As Integer, j As Integer
Dim Moy As Double
Dim Tb
 
With Worksheets(MB)
    .Range("A" & Dep).Resize(1, 2).Copy Ws.Range("A" & Des).Resize(13, 2)
    Tb = .Range("A" & Dep + 2).Resize(14, 33)
End With
 
For j = 2 To 33
    Moy = Vale(Ini(1, j))
    For i = 1 To 13
        Tb(i, j) = Vale(Tb(i, j)) - Moy
    Next i
Next j
 
With Ws.Range("C" & Des).Resize(13, 33)
    .Value = Tb
    .Borders.LineStyle = xlContinuous
End With
 
End Sub
 
Private Function Vale(ByVal Str As String) As Double
 
Vale = Val(Replace(Str, ",", "."))
End Function
'------------------------------------------------------------------------------------------
'Procédure qui permet de transférer les données du Cycle Final
'------------------------------------------------------------------------------------------
 
Private Sub CycleFinal(ByVal Ws As Worksheet)
 
With Ws
    'On copie le tableau correspondant au Cycle 0
    Worksheets(MB).Range("A365").CurrentRegion.Copy .Range("C301")
 
    Call Moyenne(Ws, 317)
    .Range("C303:AI317").Borders.LineStyle = xlContinuous
End With
End Sub
 
'------------------------------------------------------------------------------------------
'Procédure qui permet de faire la moyenne d'un tableau de Np lignes et Nv colonnes
'à partir de la ligne Lig
'ici c'est utile pour faire la moyenne du tableau cycle 0 et cycle final
'------------------------------------------------------------------------------------------
Private Sub Moyenne(ByVal Ws As Worksheet, ByVal Lig As Integer)
 
With Ws
    With .Range("B" & Lig - 15)
        .Value = IIf(Lig = 19, "R_Ini", "R_Final")
        .Font.Bold = True
    End With
 
    'on fait la moyenne par colonne
    .Range("C" & Lig) = "Moyenne"
    With .Range("D" & Lig & ":AI" & Lig)
        .FormulaR1C1 = "=AVERAGE(R[" & -1 * 13 & "]C:R[-1]C)"
        .Value = .Value
        .NumberFormat = "0.00"
    End With
 
    'mises en forme diverses
    With .Range("C" & Lig & ":AI" & Lig)
        .Font.Bold = True
        .Interior.ColorIndex = 37
        .Borders.LineStyle = xlContinuous
    End With
End With
End Sub
 
'------------------------------------------------------------------------------------------
'Procédure qui permet de faire la synthèse des cycles en prenant pour chaque voie le max des Positions A et B
'le tableau de synthèse est écrit à partir de la ligne 323
'Pour trouver le max avec condition, j'utilise la formule excel =MAX(SI(PlageCritere=Critere;PlageCalcul;""))
'------------------------------------------------------------------------------------------
 
Private Sub TabSynthese(ByVal Ws As Worksheet)
 
With Ws
    .Range("C4:AI5").Copy .Range("C323")
    .Range("C325").Resize(10, 1).Formula = "=""Cycle ""&ROW()-324"
    .Range("D325").FormulaArray = "=MAX(IF($A$21:$A$299=$C325,D$21:D$299,""""))"
    .Range("D325").AutoFill .Range("D325").Resize(10, 1)
    .Range("D325").Resize(10, 1).AutoFill .Range("D325").Resize(10, 32)
    With .Range("C325").Resize(10, 33)
        .Value = .Value
        .Borders.LineStyle = xlContinuous
    End With
    .Range("C19:AI19").Copy .Range("C335")
    .Range("C335") = "R_Ini"
 
    .Range("C317:AI317").Copy .Range("C336")
    .Range("C336") = "R_Fin"
 
 
    Call TriHorizontal(.Range("D323:AI336"))
 
    .Range("D325:AI336").NumberFormat = "0.0"
End With
End Sub
 
 
Private Sub TriHorizontal(ByVal Plage As Range)
 
With Plage.Parent
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=Plage.Offset(1, 0).Resize(1, Plage.Columns.Count), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange Plage
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    .Sort.SortFields.Clear
End With
End Sub

Merci L'interret que tu porte toujoursà mon sujet ...

Sinon ,La procédure fonctionne trés bien ,Or il manque deux ptite chose que je vais essayé de travaillé sur :

1) Garder les feuils de calcule de chacun des fichier selectionnés - Calcul Resistance + Evolut Max -

2) Faire coller les tableaux de résultats l'un prés de l'autre et non plus l'un sous l'autre

Je vais essayé de résoudre ces deux dificultée et je te renvoyerais le résultat que je vais obtenir :) ..

Merci Chef !

Bonjour ,

J'ai pu arriver à résoudre les deux dernier probléme de la partie de calcule .

Voilà le code :

Code:

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
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
 
Option Explicit
 
Const CREM As String = "Calcul Resistance + Evolut Max"    'Nom de la feuille de calcul
Const MB As String = "Mesure Bending"              'Nom de la feuille de base
'------------------------------------------------------------------------------------------
'Procédure principale
'------------------------------------------------------------------------------------------
Sub Principale()
Dim Lefichier, j As Variant
Dim WsCR As Worksheet
Dim i As Integer
Dim Tmp, TbSyn
 
Application.ScreenUpdating = False
 
Call Suprsh
 
Lefichier = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , , , True)
 
If IsArray(Lefichier) Then
For j = LBound(Lefichier, 1) To UBound(Lefichier, 1)
If ImportData(Lefichier(j)) Then
    'Appel de Cycle 0
    Call CycleZero(WsCR)
 
    'Appel pour les autres cycles
    Tmp = WsCR.Range("C19:AI19")
 
    For i = 1 To 20
        Call CycleN(WsCR, Tmp, 8 + 17 * i, 7 + 14 * i)
    Next i
 
    Call CycleFinal(WsCR)
 
    Call Synthese(WsCR)
 
    TbSyn = WsCR.Range("C324:AI336")
    'ici on va continuer le code pour les autres traitements
    'La variable TbSyn comporte déjà les données de synthèse brutes qu'on va par la suite traiter
 
    Set WsCR = Nothing
 
 
End If
Next j
Call synt
MsgBox "Traitement terminé", , "Confirmation"
Else
    MsgBox "Aucun fichier n'est sélectionné", , "Annulation"
    End If
End Sub
 
'------------------------------------------------------------------------------------------
'Fonction booléenne qui est VRAI lorsque l'import a réussi
'après avoir ouvert le fichier entré en paramètre, copié toutes les donnée de la feuille 1
'dans la feuille Mesure Bending et fermeture du fichier
'------------------------------------------------------------------------------------------
Private Function ImportData(ByVal Fichier As Variant) As Boolean
Dim Wbk As Workbook
 
If Dir(Fichier) <> "" Then
    Set Wbk = Workbooks.Open(Fichier)
    With ThisWorkbook.Worksheets(MB)
        .UsedRange.Clear
        Wbk.Worksheets(1).UsedRange.Copy .Range("A1")
    End With
    Wbk.Close False
    Set Wbk = Nothing
    ImportData = True
End If
End Function
 
'------------------------------------------------------------------------------------------
'Fonction qui retourne la feuille Str
'Si la feuille Existe, on l'efface
'Sinon, on la créé et on la nomme avec le contenu de la variable Str
'------------------------------------------------------------------------------------------
Private Function CreateSheet(ByVal Str As String) As Worksheet
 
On Error Resume Next
 
On Error GoTo 0
 
Dim o As Variant
o = Worksheets.Count
 
    Set CreateSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(o))
    CreateSheet.Name = Str & o
 
End Function
 
'------------------------------------------------------------------------------------------
'Procédure qui établit le premier tableau correspondant au Cycle 0
'------------------------------------------------------------------------------------------
Private Sub CycleZero(ByRef Ws As Worksheet)
 
Set Ws = CreateSheet(CREM)
With Ws
    'On copie le tableau correspondant au Cycle 0
    Worksheets(MB).Range("A6").CurrentRegion.Copy .Range("C2")
 
    Call Moyenne(Ws, 19)
    With .Range("C4:AI5")
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .Range("C4:AI19").Borders.LineStyle = xlContinuous
End With
End Sub
 
'------------------------------------------------------------------------------------------
'Procédure qui permet de transférer les données du Cycle N
'après avoir retranché la moyenne de chaque voie du cycle 0
'Ici j'utilise une variable tableau Tb pour les calculs intermidiaires
'------------------------------------------------------------------------------------------
 
Private Sub CycleN(ByVal Ws As Worksheet, ByVal Ini, ByVal Dep As Integer, ByVal Des As Integer)
Dim i As Integer, j As Integer
Dim Moy As Double
Dim Tb
 
With Worksheets(MB)
    .Range("A" & Dep).Resize(1, 2).Copy Ws.Range("A" & Des).Resize(13, 2)
    Tb = .Range("A" & Dep + 2).Resize(14, 33)
End With
 
For j = 2 To 33
    Moy = Vale(Ini(1, j))
    For i = 1 To 13
        Tb(i, j) = Vale(Tb(i, j)) - Moy
    Next i
Next j
 
With Ws.Range("C" & Des).Resize(13, 33)
    .Value = Tb
    .Borders.LineStyle = xlContinuous
End With
 
End Sub
 
Private Function Vale(ByVal Str As String) As Double
 
Vale = Val(Replace(Str, ",", "."))
End Function
'------------------------------------------------------------------------------------------
'Procédure qui permet de transférer les données du Cycle Final
'------------------------------------------------------------------------------------------
 
Private Sub CycleFinal(ByVal Ws As Worksheet)
 
With Ws
    'On copie le tableau correspondant au Cycle 0
    Worksheets(MB).Range("A365").CurrentRegion.Copy .Range("C301")
 
    Call Moyenne(Ws, 317)
    .Range("C303:AI317").Borders.LineStyle = xlContinuous
End With
End Sub
 
'------------------------------------------------------------------------------------------
'Procédure qui permet de faire la moyenne d'un tableau de Np lignes et Nv colonnes
'à partir de la ligne Lig
'ici c'est utile pour faire la moyenne du tableau cycle 0 et cycle final
'------------------------------------------------------------------------------------------
Private Sub Moyenne(ByVal Ws As Worksheet, ByVal Lig As Integer)
 
With Ws
    With .Range("B" & Lig - 15)
        .Value = IIf(Lig = 19, "R_Ini", "R_Final")
        .Font.Bold = True
    End With
 
    'on fait la moyenne par colonne
    .Range("C" & Lig) = "Moyenne"
    With .Range("D" & Lig & ":AI" & Lig)
        .FormulaR1C1 = "=AVERAGE(R[" & -1 * 13 & "]C:R[-1]C)"
        .Value = .Value
        .NumberFormat = "0.00"
    End With
 
    'mises en forme diverses
    With .Range("C" & Lig & ":AI" & Lig)
        .Font.Bold = True
        .Interior.ColorIndex = 37
        .Borders.LineStyle = xlContinuous
    End With
End With
End Sub
 
'------------------------------------------------------------------------------------------
'Procédure qui permet de faire la synthèse des cycles en prenant pour chaque voie le max des Positions A et B
'le tableau de synthèse est écrit à partir de la ligne 323
'Pour trouver le max avec condition, j'utilise la formule excel =MAX(SI(PlageCritere=Critere;PlageCalcul;""))
'------------------------------------------------------------------------------------------
 
Private Sub Synthese(ByVal Ws As Worksheet)
 
With Ws
    .Range("C4:AI5").Copy .Range("C323")
    .Range("C325").Resize(10, 1).Formula = "=""Cycle ""&ROW()-324"
    .Range("D325").FormulaArray = "=MAX(IF($A$21:$A$299=$C325,D$21:D$299,""""))"
    .Range("D325").AutoFill .Range("D325").Resize(10, 1)
    .Range("D325").Resize(10, 1).AutoFill .Range("D325").Resize(10, 32)
    With .Range("C325").Resize(10, 33)
        .Value = .Value
        .Borders.LineStyle = xlContinuous
    End With
    .Range("C19:AI19").Copy .Range("C335")
    .Range("C335") = "R_Ini"
 
    .Range("C317:AI317").Copy .Range("C336")
    .Range("C336") = "R_Fin"
 
 
    Call TriHorizontal(.Range("D323:AI336"))
 
    .Range("D325:AI336").NumberFormat = "0.0"
End With
End Sub
 
 
Private Sub TriHorizontal(ByVal Plage As Range)
 
With Plage.Parent
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=Plage.Offset(1, 0).Resize(1, Plage.Columns.Count), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange Plage
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    .Sort.SortFields.Clear
End With
End Sub
 
Private Sub synt()
Dim i As Variant
Dim ColAjout As Integer
 
    'On initialise le numéro de colonne pour l'ajout
    ColAjout = 1
 
    'On ajoute une feuille au classeur
 
    If Not Sheets(Sheets.Count).Name = "synthése" Then
 
    ThisWorkbook.Sheets.Add After:=Sheets(ThisWorkbook.Sheets.Count)
 
    Sheets(Sheets.Count).Name = "synthése"
    End If
 
    'Pour chaque feuille à partir de la 2eme et jusqu'à l'avant dernière
 
    For i = 2 To Sheets.Count
 
        With Sheets(i)
        If i = 2 Then
        .Range("C324:AI336").Copy ActiveSheet.Cells(1, ColAjout)
        ColAjout = ActiveSheet.Cells(1, 1).End(xlToRight).Column + 1
        Else
            'On copie la plage "D324:AI336" de chaque feuille
            'On colle cette plage dans la dernière feuille, après la dernière colonne renseignée.
            .Range("D324:AI336").Copy ActiveSheet.Cells(1, ColAjout)
            'On définit le numéro de colonne pour le prochain ajout
            ColAjout = ActiveSheet.Cells(1, 1).End(xlToRight).Column + 1
            End If
        End With
    Next i
End Sub
 
'-----------------------------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------------------------
'Procédure de suppressuion des feuils de calcule autre que celle de 'Mesure Bending'
'-----------------------------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------------------------
Private Sub Suprsh()
    Dim wb As Workbook
    Dim Ws As Worksheet
 
    Set wb = ThisWorkbook
    For Each Ws In wb.Worksheets
        Application.DisplayAlerts = False
        If Ws.Index <> 1 Then Ws.Delete
        Application.DisplayAlerts = True
    Next Ws
 
End Sub

Tu peut remarqué que j'ai appris à rajouter des Sous procédure telque Synt et Suprsh et les appeller par l'interime de Call ... Woow .. comme c'est amusant la programmation :) .. !!
***************************************************************

Je passerais maintenant à la derniére étape de traitement avant de passer à l'exportation vers word :

J'ai deux question la dessus :

Est ce que c'est possible d'avoir une constante contenat une mise en forme ??

Est ce que c'est possible d'appellé un modéle excel contenant une mise en forme par VBA ??

Merci d'avance

C'est du progrès et c'est bien. Je te féllicite

Sauf que tu as encore des Activesheet que tu dois régler.

Sinon, pour la fond, tu détruis les feuilles existantes avant de les re créer alors qu'il te suffit d'effacer les feuilles existantes et d'en créer seulement les nouvelles.

Ci-joint ma proposition (qui peut être amélioré en supprimant les colonnes Fils et Vide avant de passer au fichier suivant)

Code:

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
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
Option Explicit
 
Const CREM As String = "CR-EMax"    'Nom de la feuille de calcul
Const MB As String = "Mesure Bending"              'Nom de la feuille de base
Const SY As String = "Synthese"                    'Nom de la feuille de synthèse
'------------------------------------------------------------------------------------------
'Procédure principale
 
'------------------------------------------------------------------------------------------
Sub Principale()
Dim NbCol As Integer, i As Integer
Dim Syn As Worksheet
Dim TbFichier
 
TbFichier = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , , , True)
If IsArray(TbFichier) Then
    Set Syn = CreateSheet(SY)
    For i = 1 To UBound(TbFichier)
        Call Traitement(TbFichier(i), i)
        NbCol = Syn.Cells(2, Syn.Columns.Count).End(xlToLeft).Column
        If NbCol > 1 Then NbCol = NbCol + 1
        With Worksheets(CREM & i)
            .Range("C2:D2").Copy Syn.Cells(1, NbCol)
            .Range("C324:AI336").Copy Syn.Cells(2, NbCol)
        End With
    Next i
    Set Syn = Nothing
    MsgBox "Traitement terminé", , "Confirmation"
Else
    MsgBox "Aucun fichier n'est sélectionné", , "Annulation"
End If
End Sub
'------------------------------------------------------------------------------------------
'Procédure Traitement
'------------------------------------------------------------------------------------------
Sub Traitement(ByVal LeFichier As String, ByVal Indx As Integer)
Dim WsCR As Worksheet
Dim i As Integer
Dim Tmp
 
Application.ScreenUpdating = False
If ImportData(LeFichier) Then
    'Appel de Cycle 0
    Call CycleZero(WsCR, Indx)
 
    'Appel pour les autres cycles
    Tmp = WsCR.Range("C19:AI19")
 
    For i = 1 To 20
        Call CycleN(WsCR, Tmp, 8 + 17 * i, 7 + 14 * i)
    Next i
 
    Call CycleFinal(WsCR)
 
    Call TabSynthese(WsCR)
 
    Set WsCR = Nothing
End If
End Sub
 
'------------------------------------------------------------------------------------------
'Fonction booléenne qui est VRAI lorsque l'import a réussi
'après avoir ouvert le fichier entré en paramètre, copié toutes les donnée de la feuille 1
'dans la feuille Mesure Bending et fermeture du fichier
'------------------------------------------------------------------------------------------
Private Function ImportData(ByVal Fichier As String) As Boolean
Dim Wbk As Workbook
 
If Dir(Fichier) <> "" Then
    Set Wbk = Workbooks.Open(Fichier)
    With ThisWorkbook.Worksheets(MB)
        .UsedRange.Clear
        Wbk.Worksheets(1).UsedRange.Copy .Range("A1")
    End With
    Wbk.Close False
    Set Wbk = Nothing
    ImportData = True
End If
End Function
 
'------------------------------------------------------------------------------------------
'Fonction qui retourne la feuille Str
'Si la feuille Existe, on l'efface
'Sinon, on la créé et on la nomme avec le contenu de la variable Str
'------------------------------------------------------------------------------------------
Private Function CreateSheet(ByVal Str As String) As Worksheet
 
On Error Resume Next
Set CreateSheet = ThisWorkbook.Worksheets(Str)
On Error GoTo 0
 
'Si la feuille existe, on l'efface
If Not CreateSheet Is Nothing Then
    CreateSheet.UsedRange.Clear
    'Sinon, on ajoute une feuille vierge qu'on renomme
Else
    Set CreateSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    CreateSheet.Name = Str
End If
End Function
 
'------------------------------------------------------------------------------------------
'Procédure qui établit le premier tableau correspondant au Cycle 0
'------------------------------------------------------------------------------------------
Private Sub CycleZero(ByRef Ws As Worksheet, ByVal Indx As Integer)
 
Set Ws = CreateSheet(CREM & Indx)
With Ws
    'On copie le tableau correspondant au Cycle 0
    Worksheets(MB).Range("A6").CurrentRegion.Copy .Range("C2")
 
    Call Moyenne(Ws, 19)
    With .Range("C4:AI5")
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .Range("C4:AI19").Borders.LineStyle = xlContinuous
End With
End Sub
 
'------------------------------------------------------------------------------------------
'Procédure qui permet de transférer les données du Cycle N
'après avoir retranché la moyenne de chaque voie du cycle 0
'Ici j'utilise une variable tableau Tb pour les calculs intermidiaires
'------------------------------------------------------------------------------------------
 
Private Sub CycleN(ByVal Ws As Worksheet, ByVal Ini, ByVal Dep As Integer, ByVal Des As Integer)
Dim i As Integer, j As Integer
Dim Moy As Double
Dim Tb
 
With Worksheets(MB)
    .Range("A" & Dep).Resize(1, 2).Copy Ws.Range("A" & Des).Resize(13, 2)
    Tb = .Range("A" & Dep + 2).Resize(14, 33)
End With
 
For j = 2 To 33
    Moy = Vale(Ini(1, j))
    For i = 1 To 13
        Tb(i, j) = Vale(Tb(i, j)) - Moy
    Next i
Next j
 
With Ws.Range("C" & Des).Resize(13, 33)
    .Value = Tb
    .Borders.LineStyle = xlContinuous
End With
 
End Sub
 
Private Function Vale(ByVal Str As String) As Double
 
Vale = Val(Replace(Str, ",", "."))
End Function
'------------------------------------------------------------------------------------------
'Procédure qui permet de transférer les données du Cycle Final
'------------------------------------------------------------------------------------------
 
Private Sub CycleFinal(ByVal Ws As Worksheet)
 
With Ws
    'On copie le tableau correspondant au Cycle 0
    Worksheets(MB).Range("A365").CurrentRegion.Copy .Range("C301")
 
    Call Moyenne(Ws, 317)
    .Range("C303:AI317").Borders.LineStyle = xlContinuous
End With
End Sub
 
'------------------------------------------------------------------------------------------
'Procédure qui permet de faire la moyenne d'un tableau de Np lignes et Nv colonnes
'à partir de la ligne Lig
'ici c'est utile pour faire la moyenne du tableau cycle 0 et cycle final
'------------------------------------------------------------------------------------------
Private Sub Moyenne(ByVal Ws As Worksheet, ByVal Lig As Integer)
 
With Ws
    With .Range("B" & Lig - 15)
        .Value = IIf(Lig = 19, "R_Ini", "R_Final")
        .Font.Bold = True
    End With
 
    'on fait la moyenne par colonne
    .Range("C" & Lig) = "Moyenne"
    With .Range("D" & Lig & ":AI" & Lig)
        .FormulaR1C1 = "=AVERAGE(R[" & -1 * 13 & "]C:R[-1]C)"
        .Value = .Value
        .NumberFormat = "0.00"
    End With
 
    'mises en forme diverses
    With .Range("C" & Lig & ":AI" & Lig)
        .Font.Bold = True
        .Interior.ColorIndex = 37
        .Borders.LineStyle = xlContinuous
    End With
End With
End Sub
 
'------------------------------------------------------------------------------------------
'Procédure qui permet de faire la synthèse des cycles en prenant pour chaque voie le max des Positions A et B
'le tableau de synthèse est écrit à partir de la ligne 323
'Pour trouver le max avec condition, j'utilise la formule excel =MAX(SI(PlageCritere=Critere;PlageCalcul;""))
'------------------------------------------------------------------------------------------
 
Private Sub TabSynthese(ByVal Ws As Worksheet)
 
With Ws
    .Range("C4:AI5").Copy .Range("C323")
    .Range("C325").Resize(10, 1).Formula = "=""Cycle ""&ROW()-324"
    .Range("D325").FormulaArray = "=MAX(IF($A$21:$A$299=$C325,D$21:D$299,""""))"
    .Range("D325").AutoFill .Range("D325").Resize(10, 1)
    .Range("D325").Resize(10, 1).AutoFill .Range("D325").Resize(10, 32)
    With .Range("C325").Resize(10, 33)
        .Value = .Value
        .Borders.LineStyle = xlContinuous
    End With
    .Range("C19:AI19").Copy .Range("C335")
    .Range("C335") = "R_Ini"
 
    .Range("C317:AI317").Copy .Range("C336")
    .Range("C336") = "R_Fin"
 
 
    Call TriHorizontal(.Range("D323:AI336"))
 
    .Range("D325:AI336").NumberFormat = "0.0"
End With
End Sub
 
 
Private Sub TriHorizontal(ByVal Plage As Range)
 
With Plage.Parent
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=Plage.Offset(1, 0).Resize(1, Plage.Columns.Count), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange Plage
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    .Sort.SortFields.Clear
End With
End Sub

PS. Attention au nombre maximum des colonnes d'une feuille excel

Merci

çà marche bien ... j'ai encore ce probléme de active sheet et de select ...s'il te plaît peut tu m'expliquer coment puis-je optimiser ce code on utilisant ta méthode qui consiste à un trasfert direct de range ... Or moi j'arrive pas à basculer facilement entre les feuils sans se reférer à select ou activate que je sais méme pas la vrais signification de chacune .... J'ai essayé d'auprés ton code comprendre la démarche que tu as suivis mais j'ai pas arrivée à faire extraire la méthode faite ...

code :
Code:

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 Const exp As String = "Exporter vers word" With Sheets("Synthése") .Range("B12").Select .Range(Selection, Selection.End(xlDown)).Select .Range(Selection, Selection.End(xlToRight)).Select Selection.Copy exp.Range("B6").Paste Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False .Range("B1").Select .Range(Selection, Selection.End(xlToRight)).Select Selection.Copy exp.Range("B4").Paste Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False exp.Range("B12").Paste Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False .Range("B2:B11").Select .Range(Selection, Selection.End(xlToRight)).Select Selection.Copy exp.Range("B13").Paste Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End With
**************************************************************

12/04/2013, 21h10
mercatog
Pour copier les valeurs d'une plage de FeuilleY vers Feuille X, tu peux faire par exemple

Code:

Worksheets("FeuilleX").range("A3:X34").value=Worksheets("FeuilleY").range("B9:Y40").value

Sans rien sélectionner, ni activer

Pour ton cas particulier, il faudra décrire l'organisation des données à copier et où copier pour pouvoir te proposer quelque chose de potable

PS: Quand tu fais
Code:

1 2 Const Exped As string="toto" Exped.range("A1")="Tutu"
ça n'a aucun sens, Exped est un string

il fallait faire

Code:

Worksheets(Exped).range("A1")="Tutu"

Bonjour Monsieur ,

J'ai essayé d'utilisé mais çà n'as pas marché et j'en suis sure que j'ai fais une erreur quelque part .. :/ .. il me manque quelque chose :/
Merci de me voir ce ptit bout de code .. il bug au niveau de ligne de transfert ! :(
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 Private Sub exp() Const expo As String = "Exporter vers word" Const synt As String = "synthése" Dim Cr, Cl, Cu, Cd As Integer Cr = Sheets(synt).Cells(12, 2).End(xlToRight).Column With Sheets(expo) .Range(Cells(6, 2), Cells(7, Cr)).Value = Sheets(synt).Range(Cells(12, 2), Cells(13, Cr)).Value End With End
:) .. merci d'avance !

22/04/2013, 13h00
Matrixmax

1 pièce(s) jointe(s)

La fin

Enfin je viens de finir le travail sur ce projet.

Vous trouvez ci-joint le code que j'ai établis pour exporter le tableau de résultat vers word ...

merci à Monsieur Mercatog et à toute personne ayant contribuée au succés de ce travail .. trés grand merci .. !!

Voir 40 message(s) de cette discussion en une page