Discussion :

[Stan_fr]

Pourquoi "à la main" ?
La mise en place de MFC dans les multiples onglets d'un classeur, ça peut se faire aussi par macro.
L'avantage, c'est que tu ne lances la macro que pour chaque modif. Le reste du temps, tes MFC seront plus rapides et/ou dynamiques que des macros.

En fait ce n'est pas la mise en place des MFC qui pose problème :
voilà j'essaie de faire un truc pour ma femme et je suis légèrement daltonien alors quand elle regarde elle me dit que c'est atrocement laid donc je change les couleurs, les dégradés etc. dans mes MFC sur une feuille et je reporte dans les autres...
Ça peut aussi se faire simplement par Macro ?

Ci-joint les membres de Interior.
Tu peux y voir l'objet Gradient. Il te suffit de suivre la chaine des liens pour savoir tout ce que tu souhaites à ce sujet.
https://msdn.microsoft.com/fr-fr/VBA...r-object-excel

Merci, mais aussi bien là qu'ailleurs il n'y a que la construction de dégradés en effaçant au préalable l'existant, rien sur la façon de récupérer le nombre de ColorStops ; c'est peut-être tout simple mais je débute et ça m'échappe

[unparia]

Hello Stab-fr

alors quand elle regarde elle me dit que c'est atrocement laid donc je change les couleurs, les dégradés etc.

Ton épouse a probablement beaucoup de goût.

Je vais te dire un "non-secret" : rien ne vaut la sobriété en matière d'interfaces. Ecoute ton épouse.

Couleurs sobres et peu diverses
Les effets et styles doivent rester exceptionnels

[Menhir]

Ça peut aussi se faire simplement par Macro ?

Presque tout ce qui peut se faire "à la main" (sans engager la réflexion humaine) peut se faire en VBA.

[Stan_fr]

Hi unparia

Hello Stab-fr



Ton épouse a probablement beaucoup de goût.

Sans doute puisqu'elle elle m'a choisi !

Je vais te dire un "non-secret" : rien ne vaut la sobriété en matière d'interfaces. Ecoute ton épouse.

Couleurs sobres et peu diverses
Les effets et styles doivent rester exceptionnels

Je suis d'accord sur le principe, le problème c'est que quand tu les vois mal difficile de dire si les couleurs sont sobres et peu diverses

[patricktoulon]

bonjour

application d'un degragé dans une cellule
interrogation si oui/non la cellule est en degradé
donne le nombre de couleur du degradé
donne toute les couleurs du degradé

constante explicit

Code :

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

1
2
3
4
5
Option Explicit
Const HRTZHB = 90    'HORIZONTAL HAUT VERS BAS
Const HRTZBH = -90    'HORIZONTAL BAS VERS HAUT
Const VERTGD = 0    'VERTCAL DROITE VERS LA GAUCHE
Const VERTDG = 180    'VERTCAL  GAUCHE VERS LA DROITE

sub de test

Code :

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

1
2
3
4
5
6
7
8
Sub test()
    Dim couleur(3)
    couleur(1) = 15983062
    couleur(2) = 15587784
    couleur(3) = 16577757
    Gradient Range("A1"), HRTZHB, couleur
 
End Sub

fonction qui applique le degradé

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
Function Gradient(plage, sens, couleur)
    Dim rng As Range, cs As ColorStop, grd1 As LinearGradient
    Set rng = plage
    rng.Interior.Color = couleur(1)
    'rng.Cells.Merge
    rng.Interior.Pattern = XlPattern.xlPatternLinearGradient
    Set grd1 = rng.Interior.Gradient
    grd1.Degree = sens    'on applique le sens du dégradé au depart
 
    Set cs = grd1.ColorStops.Add(0.2)    ''on met la 1 ere couleur eton la degrade jusqu'a 20% de la taille de la plage
    cs.Color = couleur(1)
    cs.TintAndShade = 0    'Réglez l'ombrage : -1 est noir , 1 est blanc, 0 est la couleur (enleve le meme probleme qu'avec les shape gradient (couleur blanche persistente )
 
    Set cs = grd1.ColorStops.Add(0.5)
    cs.Color = couleur(2)
    cs.TintAndShade = 0
    Set cs = grd1.ColorStops.Add(1)    ' ajout de la derniere couleur a 100% de la largeur ou de la hauteur selon le degré
    cs.Color = couleur(3)
    cs.TintAndShade = 0
End Function

sub pour tester si degradé

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub test2()
    Dim degradé As Boolean, couleurs, grd1, i
    degradé = [A1].Interior.Pattern = 4000
    If degradé = True Then
        Debug.Print "il y a bien un degré dans cette cellule"
        Set grd1 = [A1].Interior.Gradient
        Debug.Print "le sens du dégradé est " & grd1.Degree  ' sens du dégradé
        Debug.Print "le nombre de couleur est de " & grd1.ColorStops.Count - 2
    For i = 2 To grd1.ColorStops.Count
    Debug.Print "couleur" & i & "= " & grd1.ColorStops(i).Color
    Next
    End If
End Sub

je n'ai jamais trouvé comment connaitre les points d'arret des couleurs
a+

[Stan_fr]

bonjour

...

je n'ai jamais trouvé comment connaitre les points d'arret des couleurs
a+

Bonjour,

Après avoir pas mal galéré j'ai trouvé il faut utiliser la propriété Position de ColorStop :

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
Option Explicit
 
Private Sub Worksheet_Activate()
 
    Cpy_Format Range("A1"), Range("B1")
 
End Sub
 
 
Private Sub Cpy_Format(ByVal T1 As Range, ByVal T2 As Range)
Dim Coul(1 To 20) As Long
Dim Coul_Stop(1 To 20) As Double
Dim I As Long
Dim L_Collec As Long
 
    T2.Interior.Color = T1.Interior.Color
 
    T2.Interior.Pattern = T1.Interior.Pattern               ' OK si Pattern est un motif prédéfini ...
 
    'MsgBox T2.Interior.Pattern
 
    If T2.Interior.Pattern = 4000 Then
 
    L_Collec = T1.Interior.Gradient.ColorStops.Count
 
    For I = 1 To L_Collec
 
        Coul(I) = T1.Interior.Gradient.ColorStops(I).Color
        Coul_Stop(I) = T1.Interior.Gradient.ColorStops(I).Position
        MsgBox Coul(I) & " " & Coul_Stop(I)
 
    Next I
 
    End If
 
    T2.Interior.PatternColor = T1.Interior.PatternColor
 
End Sub

Bon moi...

A bientôt !

Merci à tout le monde !!!

[patricktoulon]

re
a ben oui!!!!! "Position"

bon ben voila maintenant tu sais comment faire en ecriture et comment cela est fait en lecture
je fait une fonction parametrable demain avec tout ca
le principe

1. si le patern=4000 pour le test gradient (oui/non)
2. le degree pour le sens
3. boucle sur les colorstops(".color","position")pour les données

je regarde pour le type de gradient aussi demain

[Stan_fr]

re
a ben oui!!!!! "Position"

bon ben voila maintenant tu sais comment faire en ecriture et comment cela est fait en lecture
je fait une fonction parametrable demain avec tout ca
le principe

1. si le patern=4000 pour le test gradient (oui/non)
2. le degree pour le sens
3. boucle sur les colorstops(".color","position")pour les données

je regarde pour le type de gradient aussi demain

Bonjour,

J'ai fait pour les gradients linéaires (avec des bricoles en plus...) :

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
Option Explicit
Private Const LIN_GRAD As Long = 4000 ' Code pour gradient linéaire
Private Const REC_GRAD As Long = 4001 ' Code pour gradient rectangulaire
 
 
Private Sub Worksheet_Activate()
 
    Demo
 
End Sub
 
'
'
' T1 Range Source, T2 Range Destination, Rot Rotation du dégradé : si absent on conserve celle d'origine, Rep nombre de répétion du motif : si absent pas de répétition...
'
'
Private Sub Cpy_Format(ByVal T1 As Range, ByVal T2 As Range, Optional ByVal Rot, Optional ByVal Rep)
Dim Coul(1 To 60)           As Long
Dim Coul_Stop(1 To 60)      As Double
Dim Coul_Offset             As Double
Dim Deg                     As Long
Dim I                       As Long
Dim J                       As Long
Dim L_Collec                As Long
Dim Nb_Rep                  As Long
Dim Rotation                As Integer
Dim Tint(1 To 60)           As Long
 
    T2.Interior.Color = T1.Interior.Color
 
    T2.Interior.Pattern = T1.Interior.Pattern               ' OK si Pattern est un motif prédéfini ...
 
    Select Case T1.Interior.Pattern
 
        Case Is = LIN_GRAD      ' Gradient Linéaire
 
            T2.Interior.Gradient.ColorStops.Clear
 
            If IsMissing(Rot) Then
                T2.Interior.Gradient.Degree = T1.Interior.Gradient.Degree
            Else
                T2.Interior.Gradient.Degree = Rot ' On pourrait mettre T2.Interior.Gradient.Degree = (T1.Interior.Gradient.Degree + Rot) Mod 360 ...
            End If
            If IsMissing(Rep) Then
                Nb_Rep = 1
            Else
                Nb_Rep = Rep
            End If
            L_Collec = T1.Interior.Gradient.ColorStops.Count
            Coul_Offset = (T1.Interior.Gradient.ColorStops(L_Collec).Position) / Nb_Rep
            For J = 0 To Nb_Rep - 1
                For I = 1 To L_Collec
                    Coul_Stop(I + J * Nb_Rep) = ((T1.Interior.Gradient.ColorStops(I).Position) / Nb_Rep) + Coul_Offset * J
                    Coul(I + J * Nb_Rep) = T1.Interior.Gradient.ColorStops(I).Color
                    Tint(I + J * Nb_Rep) = T1.Interior.Gradient.ColorStops(I).TintAndShade
                Next I
            Next J
            L_Collec = L_Collec * Nb_Rep
            For I = 1 To L_Collec
 
                With T2.Interior.Gradient.ColorStops.Add(Coul_Stop(I))
 
                    .Color = Coul(I)
                    .TintAndShade = Tint(I)
 
                End With
 
            Next I
 
        Case Is = REC_GRAD
 
        Case Else
 
    End Select
 
End Sub
 
Private Sub Demo()
 
    Test_22
 
    For I = 1 To 5
        Cpy_Format Cells(1, 1), Cells(I + 1, 1), 90 + 10 * I
    Next
 
    For I = 1 To 3
        Cpy_Format Cells(1, 1), Cells(1, I + 1), , I
    Next I
 
    For I = 2 To 6
        Cpy_Format Cells(1, 1), Cells(7, I + 1), 90 + 5 * I, I / 2
    Next I
 
End Sub
 
Sub Test_22()
Dim I As Long
 
    With Cells(1, 1)
        With .Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 90
        .Gradient.ColorStops.Clear
        End With
        .Interior.Gradient.ColorStops.Add(0).Color = 676095
        .Interior.Gradient.ColorStops.Add(0.5).Color = 16777215
        .Interior.Gradient.ColorStops.Add(1).Color = 676095
    End With
 
End Sub

Je te laisse la main pour les gradients rectangulaires là il faut que j'aille m'occuper de ma salle de bains

[patricktoulon]

Bonjour Stan_fr
voila un exemple de sub pour les rectangles

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub test4()
'exemple dégradé 3 couleur en rectangle
    With Range("A1").Interior
        .Pattern = xlPatternRectangularGradient
        With .Gradient
            'la ligne suivante pour excentrer ou centrer  et dimentionner le  rectangle du centre
            .RectangleLeft = 0.4: .RectangleRight = 0.6: .RectangleTop = 0.4: .RectangleBottom = 0.6    'centrage du rectangle
            .ColorStops.Clear    'suppression des couleur
            With .ColorStops.Add(0): .Color = vbMagenta: .TintAndShade = 0: End With    'couleur 1 au centre
            With .ColorStops.Add(0.5): .Color = vbGreen: .TintAndShade = 0: End With    'couleur 2 autour de la couleur 1
            With .ColorStops.Add(1): .Color = vbRed: .TintAndShade = 0: End With    'couleur 3 autour de la couleur 2
        End With
    End With
End Sub

[Stan_fr]

Bonsoir patricktoulon,

Ça y est j'y suis arrivé : je peux copier des cellules avec gradient de tout type et même tellement les "bricoler" qu'unparia dirait que j'abuse

Code Complet (j'ai repris ta création de rectangle, le reste c'est mon code baveux à moi...)

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
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
292
293
294
Option Explicit
Private Const LIN_GRAD As Long = 4000 ' Code pour gradient linéaire
Private Const REC_GRAD As Long = 4001 ' Code pour gradient rectangulaire
 
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
    Demo
 
End Sub
 
'
'
' T1 Range Source, T2 Range Destination, Rot Rotation du dégradé : si absent on conserve celle d'origine, Rep nombre de répétion du motif : si absent pas de répétition...
'
'
Private Sub Cpy_Format(ByVal T1 As Range, ByVal T2 As Range, Optional ByVal Rot, Optional ByVal Rep, Optional ByVal Rep2)
Dim Coul(1 To 60)           As Long
Dim Coul_Stop(1 To 60)      As Double
Dim Coul_Offset             As Double
Dim Deg                     As Long
Dim I                       As Long
Dim J                       As Long
Dim L_Collec                As Long
Dim Nb_Rep                  As Long
Dim R_Bott(1 To 60)         As Double
Dim R_Left(1 To 60)         As Double
Dim R_Right(1 To 60)        As Double
Dim R_Top(1 To 60)          As Double
Dim Reduc                   As Double
Dim Rotation                As Integer
Dim Tint(1 To 60)           As Long
 
    Application.ScreenUpdating = False
 
    T2.Interior.Color = T1.Interior.Color
 
    T2.Interior.Pattern = T1.Interior.Pattern               ' OK si Pattern est un motif prédéfini ...
 
    Select Case T1.Interior.Pattern
 
        Case Is = LIN_GRAD      ' Gradient Linéaire
 
            T2.Interior.Gradient.ColorStops.Clear
 
            If IsMissing(Rot) Then
                T2.Interior.Gradient.Degree = T1.Interior.Gradient.Degree
            Else
                T2.Interior.Gradient.Degree = Rot ' On pourrait mettre T2.Interior.Gradient.Degree = (T1.Interior.Gradient.Degree + Rot) Mod 360 ...
            End If
            If IsMissing(Rep) Then
                Nb_Rep = 1
            Else
                Nb_Rep = Rep
            End If
            L_Collec = T1.Interior.Gradient.ColorStops.Count
            Coul_Offset = (T1.Interior.Gradient.ColorStops(L_Collec).Position) / Nb_Rep
            For J = 0 To Nb_Rep - 1
                For I = 1 To L_Collec
                    Coul_Stop(I + J * Nb_Rep) = ((T1.Interior.Gradient.ColorStops(I).Position) / Nb_Rep) + Coul_Offset * J
                    Coul(I + J * Nb_Rep) = T1.Interior.Gradient.ColorStops(I).Color
                    Tint(I + J * Nb_Rep) = T1.Interior.Gradient.ColorStops(I).TintAndShade
                Next I
            Next J
            L_Collec = L_Collec * Nb_Rep
            For I = 1 To L_Collec
 
                With T2.Interior.Gradient.ColorStops.Add(Coul_Stop(I))
 
                    .Color = Coul(I)
                    .TintAndShade = Tint(I)
 
                End With
 
            Next I
 
        Case Is = REC_GRAD
 
 
            T2.Interior.Pattern = REC_GRAD
 
            If IsMissing(Rep2) Then
                Reduc = 1
            Else
                Reduc = Rep2
            End If
            T2.Interior.Gradient.RectangleLeft = (T1.Interior.Gradient.RectangleLeft - 0.5) * Reduc + 0.5
            T2.Interior.Gradient.RectangleRight = (T1.Interior.Gradient.RectangleRight - 0.5) * Reduc + 0.5
            T2.Interior.Gradient.RectangleTop = (T1.Interior.Gradient.RectangleTop - 0.5) * Reduc + 0.5
            T2.Interior.Gradient.RectangleBottom = (T1.Interior.Gradient.RectangleBottom - 0.5) * Reduc + 0.5
 
            L_Collec = T1.Interior.Gradient.ColorStops.Count
            Coul_Offset = ((T1.Interior.Gradient.ColorStops(L_Collec).Position) - 0.5) * Reduc + 0.5
 
                For I = 1 To L_Collec
                    Coul_Stop(I) = (T1.Interior.Gradient.ColorStops(I).Position - 0.5) * Reduc + 0.5
                    Coul(I) = T1.Interior.Gradient.ColorStops(I).Color
                    Tint(I) = T1.Interior.Gradient.ColorStops(I).TintAndShade
                Next I
 
            T2.Interior.Gradient.ColorStops.Clear
 
            For I = 1 To L_Collec
 
                With T2.Interior.Gradient.ColorStops.Add(Coul_Stop(I))
 
                    .Color = Coul(I)
                    .TintAndShade = Tint(I)
 
                End With
 
            Next I
 
        Case Else
 
    End Select
 
    Application.ScreenUpdating = True
 
End Sub
 
Private Sub Demo()
 
Dim I       As Long
Dim J       As Long
Dim Sec1    As Single
Dim Sec2    As Single
Dim Sec3    As Single
Dim Sv_Row  As Integer
Dim Sv_Col  As Integer
 
For I = 1 To 12
    For J = 1 To 12
        Cpy_Format Cells(40, 40), Cells(I, J)
    Next J
Next I
 
Test_22
 
For I = 1 To 5
    Cpy_Format Cells(1, 1), Cells(2 * I + 1, 1), 90 + 10 * I
    Sec3 = Timer + 1
    Do While Timer < Sec3
        DoEvents
    Loop
Next
 
For I = 1 To 3
    Cpy_Format Cells(1, 1), Cells(1, 2 * I + 1), , I
    Sec3 = Timer + 1
    Do While Timer < Sec3
        DoEvents
    Loop
Next I
 
For I = 2 To 6
    Cpy_Format Cells(1, 1), Cells(7, I + 1), 90 + 5 * I, I / 2
    Sec3 = Timer + 1
    Do While Timer < Sec3
        DoEvents
    Loop
Next I
 
Sv_Row = Rows(10).RowHeight
Rows(10).RowHeight = 40
Sv_Col = Columns(10).ColumnWidth
Columns(10).ColumnWidth = 40
I = 1
Sec1 = Timer
 
Sec2 = Sec1 + 5
 
Do While Sec1 < Sec2
    DoEvents
    Cpy_Format Cells(1, 1), Cells(10, 10), (90 + 5 * I) Mod 360
    Sec3 = Timer + 0.1
    Do While Timer < Sec3
        DoEvents
    Loop
    Sec1 = Sec1 + 0.1
    I = I + 1
    DoEvents
Loop
 
MsgBox "La Suite ?"
Rows(10).RowHeight = Sv_Row
Columns(10).ColumnWidth = Sv_Col
 
For I = 2 To 6
    Cpy_Format Cells(30, 30), Cells(7, I + 1), 90 + 5 * I, I / 2
Next I
 
 
test4
 
For I = 1 To 5
    Cpy_Format Cells(2, 1), Cells(2 * I + 2, 1)
Next
 
For I = 0 To 2
    Cpy_Format Cells(2, 1), Cells(1, 2 * I + 2)
Next I
 
 
Sv_Row = Rows(10).RowHeight
Rows(10).RowHeight = 40
Sv_Col = Columns(10).ColumnWidth
Columns(10).ColumnWidth = 40
I = 1
Sec1 = Timer
 
Sec2 = Sec1 + 10
 
Do While Sec1 < Sec2
    DoEvents
    Cpy_Format Cells(2, 1), Cells(10, 10), , , 1 / I
    Sec3 = Timer + 0.2
    Do While Timer < Sec3
        DoEvents
    Loop
    Sec1 = Sec1 + 0.2
    I = I + 1
    If I > 20 Then
        Exit Do
    End If
    DoEvents
Loop
 
I = 15
Sec1 = Timer
Sec2 = Sec1 + 10
 
 
Do While Sec1 < Sec2
    DoEvents
    Cpy_Format Cells(2, 1), Cells(10, 10), , , 1 / I
    Sec3 = Timer + 0.2
    Do While Timer < Sec3
        DoEvents
    Loop
    Sec1 = Sec1 + 0.2
    I = I - 1
    If I < 1 Then
        Exit Do
    End If
 
    DoEvents
Loop
Sec3 = Timer + 3
Do While Timer < Sec3
Loop
 
MsgBox "RAZ ?"
 
For I = 1 To 12
    For J = 1 To 12
        Cpy_Format Cells(40, 40), Cells(I, J)
    Next J
Next I
Rows(10).RowHeight = Sv_Row
Columns(10).ColumnWidth = Sv_Col
 
End Sub
 
Sub Test_22()
Dim I As Long
 
    With Cells(1, 1)
        With .Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 90
        .Gradient.ColorStops.Clear
        End With
        .Interior.Gradient.ColorStops.Add(0).Color = 676095
        .Interior.Gradient.ColorStops.Add(0.5).Color = 16777215
        .Interior.Gradient.ColorStops.Add(1).Color = 676095
    End With
 
End Sub
 
Sub test4()
'exemple dégradé 3 couleur en rectangle
    With Range("A2").Interior
        .Pattern = xlPatternRectangularGradient
        With .Gradient
            'la ligne suivante pour excentrer ou centrer  et dimentionner le  rectangle du centre
            .RectangleLeft = 0.4: .RectangleRight = 0.6: .RectangleTop = 0.4: .RectangleBottom = 0.6    'centrage du rectangle
            .ColorStops.Clear    'suppression des couleur
            With .ColorStops.Add(0): .Color = vbMagenta: .TintAndShade = 0: End With    'couleur 1 au centre
            With .ColorStops.Add(0.5): .Color = vbGreen: .TintAndShade = 0: End With    'couleur 2 autour de la couleur 1
            With .ColorStops.Add(1): .Color = vbRed: .TintAndShade = 0: End With    'couleur 3 autour de la couleur 2
        End With
    End With
End Sub

Tu mets ça dans une feuille vierge et tu changes la valeur d'une case

Bonne soirée.

[eriiic]

Bonjour,

beaucoup plus court en utilisant un style :

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
Sub test()
    copierStyle [A1], "monStyle1"
    collerStyle [B1], "monStyle1"
End Sub
 
Sub copierStyle(source As Range, nomStyle As String)
    ' créer le style interior de source
    On Error Resume Next
    ActiveWorkbook.Styles(nomStyle).Delete
    On Error GoTo 0
    ActiveWorkbook.Styles.Add nomStyle, source
    With ActiveWorkbook.Styles(nomStyle)
        .IncludeNumber = False
        .IncludeFont = False
        .IncludeAlignment = False
        .IncludeBorder = False
        .IncludePatterns = True
        .IncludeProtection = False
    End With
End Sub
 
Sub collerStyle(destination As Range, nomStyle As String)
    On Error Resume Next
    destination.Style = nomStyle
    On Error GoTo 0
End Sub

eric

edit : remaniement pour séparer la création de l'application du style

[Stan_fr]

Bonsoir,

Superbe ! Là j'apprends à programmer en VBA-Excel, MERCI !!!
C'est effectivement plus élégant et plus efficace pour une copie de format que ce que j'ai fait !
...

Par contre mon code faisait bien plus, même si c'était pour "m'amuser" et surtout comprendre ce qui se passait...

Plus important si je crée des styles est-ce qu'ils sont sauvegardés avec le classeur ou au niveau d'Excel sur mon poste ?

Merci encore !

[eriiic]

Dans le classeur, d'où le ActiveWorkbook, à adapter si besoin.
Tu as vu que tu pouvais y sauvegarder d'autres formats(bordures etc), je n'ai activé que interior.
eric

[Stan_fr]

Bonjour eriiic,

Merci ça résout des tas de problèmes pour les formats !

J'avais subodoré que l'on pouvais mettre d'autres choses quand j'ai vu les .IncludeTruc = False, ce qui m'ouvre encore d'autres horizons... (et sans doute bien des arrachages de cheveux...).

Merci encore à toi et patricktoulon : grâce à vous j'ai appris bien des choses !