Discussion :

[CedLyon2018]

Bonjour,

Je vous fais part d'un problème d'exécution d'une macro VB qui met à jour un graphique et ajoute une étiquette de données avec mis en forme (Couleur).

Elle fonctionne bien en mode Débug via le pas à pas depuis F8.

Par contre en exécution directe, elle bug.

Les étiquettes s'affichent mais la mise en forme avec la modification des couleurs n'est pas prise en compte.

Sur une autre requête similaire, je n'ai même plus l'affichage des étiquettes qui se réalisent. (Voir la macro en exemple)

Si une personne à une idée sur ce problème merci d'avance

Exemple du code

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
 
Function EtiquetteParMois(ByVal NumMois As Byte)
Dim PositionPoints, i As Byte
Dim RVB As Long
'Application.ScreenUpdating = True
PositionPoints = 24 + NumMois 'Le TCD commence en 2017 M01 - 24 Points + Nb de Mois en 2019 à ajouter
'On Error Resume Next
    ActiveSheet.ChartObjects("Graphique 1").Activate
    ActiveChart.FullSeriesCollection(1).Select
 
For i = 1 To 3
 
    'ActiveChart.ChartArea.Select
    Worksheets("TCD(Par Mois)").ChartObjects("Graphique 1").Chart.FullSeriesCollection(i).DataLabels.Select
    Selection.Delete
    Worksheets("TCD(Par Mois)").ChartObjects("Graphique 1").Chart.FullSeriesCollection(i).Points(PositionPoints).Select
    Worksheets("TCD(Par Mois)").ChartObjects("Graphique 1").Chart.FullSeriesCollection(i).Points(PositionPoints).ApplyDataLabels Type:=xlShowValue
 
    Worksheets("TCD(Par Mois)").ChartObjects("Graphique 1").Chart.FullSeriesCollection(i).DataLabels.Select
    Worksheets("TCD(Par Mois)").ChartObjects("Graphique 1").Chart.FullSeriesCollection(i).Points(PositionPoints).DataLabel.Select
 
If i = 1 Then RVB = RGB(0, 112, 192)
If i = 2 Then RVB = RGB(255, 0, 0)
If i = 3 Then RVB = RGB(0, 128, 128)
 
    With Selection.Format.TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RVB
        .Transparency = 0
        .Solid
    End With
    Selection.Format.TextFrame2.TextRange.Font.Size = 10
Next i
 
End Function
 
Sub Test1()
EtiquetteParMois (5)
End Sub

[CedLyon2018]

Bonjour à tous,

J'ai trouvé une solution en simplifiant mon code.
Je lance cette macro par la sub test1 en envoyant le mois de Mai en chiffre.

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
Function EtiquetteParMois(ByVal NumMois As Byte)
Dim PositionPoints, i As Byte
Dim RVB As Long
'Application.ScreenUpdating = True
PositionPoints = 24 + NumMois 'Le TCD commence en 2017 M01 - 24 Points + Nb de Mois en 2019 à ajouter
'On Error Resume Next
    ActiveSheet.ChartObjects("Graphique 1").Activate
 
For i = 1 To 3
 
    'force l'affichage de la dernière valeur pour être sur de bien la supprimer.
    ActiveChart.FullSeriesCollection(i).Select
    ActiveChart.FullSeriesCollection(i).Points(PositionPoints - 1).Select
    ActiveChart.FullSeriesCollection(i).Points(PositionPoints - 1).ApplyDataLabels
    ActiveChart.FullSeriesCollection(i).DataLabels.Select
    Selection.Delete 'Suppression de cette étiquette du mois précédent
 
    'Affiche la dernière etiquette du mois en cours
    ActiveChart.FullSeriesCollection(i).Select
    ActiveChart.FullSeriesCollection(i).Points(PositionPoints).Select
    ActiveChart.FullSeriesCollection(i).Points(PositionPoints).ApplyDataLabels
    ActiveChart.FullSeriesCollection(i).DataLabels.Select
 
    'Mise en forme du label de l'étiquette en couleur (1 = Bleu; 2=Rouge ; 3= vert foncé)
    If i = 1 Then RVB = RGB(0, 112, 192)
    If i = 2 Then RVB = RGB(255, 0, 0)
    If i = 3 Then RVB = RGB(0, 128, 128)
 
    With Selection.Format.TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RVB
        .Transparency = 0
        .Solid
    End With
    Selection.Format.TextFrame2.TextRange.Font.Size = 10 'police en taille 10
Next i
 
End Function
 
Sub Test1()
EtiquetteParMois (5)
End Sub