XL 2016 Allègement code boucle et Aléatoire couleur

Michel_ja

XLDnaute Occasionnel
Bonjour, j'aimerai savoir comment alléger le code ci-dessous. Il me permet de créer un légende pour un graphique. Le nombre d'intitulés en Col AC et + ou - grand et je pense mettre par la suite un maximum car de toute façon la lisibilité du graph ne serait pas bonne.
J'ai joint une copie d'écran; je souhaite que dans ma légende, la police de l'intitulé soit de la même couleur que la couleur du fond de la cellule où se trouve l'intitulé, dans la Col AC, de la ligne 4 à une variable. La Col AD sert de référence uniquement (car au lancement de la macro la Col AC n'a pas de couleurs) et j'ai le code RGB en Col AE.
J'ai écrit le code ainsi, parce que je ne sait pas comment placer l'intitulé 2, 3, 4, etc. à chaque fois 20 pouces plus bas. Je pense qu'il faudrait une deuxième variable. Je l'ai fait manuellement en changent le nbre rouge dans (ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, 173, 135, 110, 110).Select.

J'espère que vous pourrez m'aider. MERCI à vous.

Sub Legende()

'Dim Brand1 As String
Dim TotalBrands As Integer
TotalBrands = LigneFin = Range("AC" & Rows.Count).End(xlUp).Row

Dim Brand1 As String
Dim Brand2 As String
Dim Brand3 As String
Dim Brand4 As String
Dim Brand5 As String
Dim Brand6 As String
Dim Brand7 As String
Dim Brand8 As String
Dim Brand9 As String
Dim Brand10 As String
Dim Brand11 As String
Dim Brand12 As String
Dim Brand13 As String
Dim Brand14 As String
Dim Brand15 As String
Dim Brand16 As String
Dim Marque As String

Brand1 = Sheets("Extract").Range("AC4").Text
Brand2 = Sheets("Extract").Range("AC5").Text
Brand3 = Sheets("Extract").Range("AC6").Text
Brand4 = Sheets("Extract").Range("AC7").Text
Brand5 = Sheets("Extract").Range("AC8").Text
Brand6 = Sheets("Extract").Range("AC9").Text
Brand7 = Sheets("Extract").Range("AC10").Text
Brand8 = Sheets("Extract").Range("AC11").Text
Brand9 = Sheets("Extract").Range("AC12").Text
Brand10 = Sheets("Extract").Range("AC13").Text
Brand11 = Sheets("Extract").Range("AC14").Text
Brand12 = Sheets("Extract").Range("AC15").Text
Brand13 = Sheets("Extract").Range("AC16").Text
Brand14 = Sheets("Extract").Range("AC17").Text
Brand15 = Sheets("Extract").Range("AC18").Text

If Worksheets("Extract").Range("AC4").Value = "" Then Exit Sub
If Worksheets("Extract").Range("AC4").Value <> "" Then ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, 173, 135, 110, 110).Select

Selection.Formula = "=Extract!AD4" '"=Extract!T4" CHANGER LA CELLULE
With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 32, 255) 'bleu foncé -1-
.Transparency = 0
.Solid
With Selection.ShapeRange.TextFrame2.TextRange.Characters(1, 1).Font
.Bold = msoTrue
.NameComplexScript = "Calibri"

End With
End With

If Worksheets("Extract").Range("AC5").Value = "" Then Exit Sub
If Worksheets("Extract").Range("AC5").Value <> "" Then ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, 173, 155, 110, 110).Select

Selection.Formula = "=Extract!AD5" '"=Extract!T4" CHANGER LA CELLULE
With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 64) 'rouge -2-
.Transparency = 0
.Solid
With Selection.ShapeRange.TextFrame2.TextRange.Characters(1, 1).Font
.Bold = msoTrue
.NameComplexScript = "Calibri"
End With
End With

If Worksheets("Extract").Range("AC6").Value = "" Then Exit Sub
If Worksheets("Extract").Range("AC6").Value <> "" Then ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, 173, 175, 110, 110).Select

Selection.Formula = "=Extract!AD6" '"=Extract!T4" CHANGER LA CELLULE
With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(30, 120, 30) 'vert foncé -3-
.Transparency = 0
.Solid
With Selection.ShapeRange.TextFrame2.TextRange.Characters(1, 1).Font
.Bold = msoTrue
.NameComplexScript = "Calibri"
End With
End With


' etc etc jusqu'à Range AC18 puis



SendKeys "{ESC}"
Range("L6").Select
End Sub
 

Pièces jointes

  • Presse-papier05.jpg
    Presse-papier05.jpg
    84.9 KB · Affichages: 37

vgendron

XLDnaute Barbatruc
Bonjour

Ce serait plus pratique d'avoir un fichier en exemple plutot qu'une image sur laquelle on nen peut rien faire...
pour les brands, tu peux surment utiliser un tableau qui contient l'ensemble des brands..
genre

VB:
Dim TotalBrands As Integer
dim Listebrands() as string
TotalBrands = LigneFin = Range("AC" & Rows.Count).End(xlUp).Row 'ca fonctionne ca????

redim ListeBrands(1 to TotalBrands)
for i = lbound(ListeBrands,1) to ubound(ListeBrands,1)
     Listebrands(i,1)=Sheets("Extract").Range("AC" &3+i).Text
next i
 

vgendron

XLDnaute Barbatruc
Avec ce code.. ca semble faire le travail....aux couleurs prêt..

VB:
Sub Legende()

If Worksheets("Extract").Range("AC4").Value = "" Then Exit Sub 'si pas de marque, on sort direct

Dim TotalBrands As Integer
Dim ListeBrands() As Variant
TotalBrands = Range("AC" & Rows.Count).End(xlUp).Row - 3 '-3 pour enlever les lignes d'entete


ReDim ListeBrands(1 To TotalBrands, 1 To 1) 'on dimensionne le tableau des marques
For i = LBound(ListeBrands, 1) To UBound(ListeBrands, 1) 'on remplit avec la colonne AC
     ListeBrands(i, 1) = Sheets("Extract").Range("AC" & 3 + i).Text
Next i

For i = LBound(ListeBrands, 1) To UBound(ListeBrands, 1)
    ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, 173, 135, 110, 110).Select
    Selection.Formula = "=Extract!AD" & i + 3 '"=Extract!T4" CHANGER LA CELLULE
    Couleur = Range("AC" & i + 3).Interior.ColorIndex 'récupère la couleur de la cellule ACi
    With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.RGB = QBColor(Couleur) 'voir correspondance entre colorindex, RGB.....
        .Transparency = 0
        .Solid
        With Selection.ShapeRange.TextFrame2.TextRange.Characters(1, 1).Font
            .Bold = msoTrue
            .NameComplexScript = "Calibri"
        End With
    End With
Next i

SendKeys "{ESC}"
Range("L6").Select
End Sub
 

vgendron

XLDnaute Barbatruc
et hop.avec la couleur qui va bien
VB:
Sub Legende()

If Worksheets("Extract").Range("AC4").Value = "" Then Exit Sub 'si pas de marque, on sort direct

Dim TotalBrands As Integer
Dim ListeBrands() As Variant
TotalBrands = Range("AC" & Rows.Count).End(xlUp).Row - 3 '-3 pour enlever les lignes d'entete

Dim CoulRVB As Long
Dim Bleu As Integer
Dim Vert As Integer
Dim Rouge As Integer

ReDim ListeBrands(1 To TotalBrands, 1 To 4) 'on dimensionne le tableau des marques avec les codes RGB pour la coleur
For i = LBound(ListeBrands, 1) To UBound(ListeBrands, 1) 'on remplit avec la colonne AC
    ListeBrands(i, 1) = Sheets("Extract").Range("AC" & 3 + i).Text
    CoulRVB = Range("AC" & i + 3).Interior.Color
    ListeBrands(i, 2) = Int(CoulRVB Mod 256)
    ListeBrands(i, 3) = Int((CoulRVB Mod 65536) / 256)
    ListeBrands(i, 4) = Int(CoulRVB / 65536)
Next i

For i = LBound(ListeBrands, 1) To UBound(ListeBrands, 1)
    ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, 173, 135, 110, 110).Select
    Selection.Formula = "=Extract!AD" & i + 3 '"=Extract!T4" CHANGER LA CELLULE
    With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(ListeBrands(i, 2), ListeBrands(i, 3), ListeBrands(i, 4)) 'voir correspondance entre colorindex, RGB.....
        .Transparency = 0
        .Solid
        With Selection.ShapeRange.TextFrame2.TextRange.Characters(1, 1).Font
            .Bold = msoTrue
            .NameComplexScript = "Calibri"
        End With
    End With
Next i

SendKeys "{ESC}"
Range("L6").Select
End Sub

Le seul ennui que je vois encore, c'est que les shapes sont créées les unes au dessus des autres...
 

Michel_ja

XLDnaute Occasionnel
Grand Merci vgendron; ça marche. Il y avait un bug lorsque je testais le code depuis une autre feuille alors j'ai ajouté la sélection de la feuille. Dans la même logique le code qui séléctionne la feuille où se trouve le graphique. Enfin j'ai également ajouté après For i = LBound(ListeBrands, 1) To UBound(ListeBrands, 1) le code suivant
ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, 173, Hauteur, 110, 110).Select
où Hauteur est une variable qui commence à 130 et à laquelle on ajoute 20 pts à chaque changement de marque.
Il va falloir que je me familiarise avec Lbound, Ubound, etc.
Merci Merci.
 

Discussions similaires

Réponses
16
Affichages
2 K

Statistiques des forums

Discussions
311 725
Messages
2 081 943
Membres
101 849
dernier inscrit
florentMIG