[XL-2016] Macro VBA - Ajout d'étiquette de donnée - Fonctionne en mode Débug (F8) et pas en exécution directe

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:

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

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