Re : Couleurs des formes (shapes) en fonction de
J'aimerai pouvoir mettre tout le fichier mais son poids ne le permet pas ! mais je j'écris ci-bas un extrait du code, c'est très long et fonctionne sur un système de If en boucle par rapport à un tableau. Hachurage et le nom d'une forme qu'on copie à l'identique et Caractère1 un bloc texte qui vient se positionner au dessus du rectangle !!
Positionx = 1100
Positiony = 1500 'position hauteur dans la page
taillex = Cells(46, 20) 'largeur colonne inscrite dans la cellule
tailley = Cells(47, 20) 'hauteur colonne inscrite
Dim Platform As String
Dim PlatformAv As String
Dim PlatformAp As String
Dim Marque As String
Dim TotalPlatform As Double
Dim TotalPlatformAv As Double
Dim Compteur As Double
Dim Compteur2 As Double
Compteur = -3
Compteur2 = 11
' traitement des variables
For i = 5 To 14 'i = colonnes
For j = 9 To 88 'j = lignes
Marque = Cells(j, 3).Text
Platform = Cells(j, 2).Text
PlatformAv = Cells(j, i).Offset(-1, Compteur).Value
PlatformAp = Cells(j, i).Offset(1, Compteur).Value
TotalPlatformAv = Cells(j, i).Offset(-1, Compteur2).Value
If Cells(j, i).Value <> 0 And Cells(j, i).Value <> "" And Platform = PlatformAv And Platform = PlatformAp Then
ActiveSheet.Shapes("Hachurage").Select
Selection.Copy
ActiveSheet.Paste
TotalPlatform = Cells(j, 16).Value
Selection.ShapeRange.Left = Positionx
Selection.ShapeRange.Top = Positiony - Cells(j, 19).Value - 4
Selection.ShapeRange.Width = 20
Selection.ShapeRange.Height = Cells(j, 19).Value
Selection.Name = "Rectangle" & Marque & i & "&" & j
ActiveSheet.Shapes("Caractère1").Select
Selection.Copy
ActiveSheet.Paste
Selection.ShapeRange.Left = Positionx + 5 / 2
Selection.ShapeRange.Top = Positiony - Cells(j, 19).Value / 2
Selection.ShapeRange.Width = 0#
Selection.ShapeRange.Height = 0#
Selection.ShapeRange(1).TextFrame.AutoSize = msoTrue
Selection.Characters.Text = Cells(j, 4).Text
Positiony = Positiony - Cells(j, 19).Value - 4