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

M

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: 38
Trier par date Trier par votes
vgendron

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
 
Vote positif 0 Vote négatif
vgendron

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
 
Vote positif 0 Vote négatif
vgendron

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...
 
Vote positif 0 Vote négatif
M

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.
 
Vote positif 0 Vote négatif

Discussions similaires

lynyrd
  • Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
528
AtTheOne
AtTheOne
L
  • Question
VBA : erreur sur boucle
Réponses
2
Affichages
278
Latias
L
D
  • Question
XL 2021 VBA - Erreur 1004 aléatoire - Image/Logo
Réponses
10
Affichages
648
crocrocro
C
M
  • Résolu(e)
XL 2016 Amélioration de code
Réponses
3
Affichages
557
M@xu3L
M
Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
1 K
Nicolas JACQUIN
Nicolas JACQUIN
I
  • Question
XL 2016 Mon code VBA me renvoi une erreur
Réponses
6
Affichages
685
INFINITY100
I
I
  • Question
XL 2016 Modification d'une ligne dans mon code
Réponses
2
Affichages
577
INFINITY100
I
M
  • Question
XL 2010 Calcul possible dans la zone de liste pour le débit et le crédit lors d'une recherche basée sur la zone de texte
Réponses
0
Affichages
633
Mody200
M
A
  • Question
XL 2019 Résolu - Bug code VBA modifier xxx fichiers en boucle
Réponses
3
Affichages
608
fanch55
fanch55
M
  • Résolu(e)
XL 2013 Recherche selon critère et transposer des données avec récurrence
Réponses
3
Affichages
1 K
MarieChérie
M

Membres actuellement en ligne

15 membres et 94 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 093
Messages
2 116 122
Membres
112 666
dernier inscrit
Coco0505