Paramètres de graphiques

Version imprimable

16/01/2013, 20h55
gaston64

Paramètres de graphiques

à partir d'une macro VBA, je souhaite supprimer le cadre du graphique et colorier le fond de la série nommée "etalon". J'ai essayé avec l'enregistreur de macro mais je ne suis pas parvenu à adapter la syntaxe

ci-joint mon fichier

Comment faire? Merci

Sur ton fichier

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub FormaterGraph()
Dim Pt As Point
Dim i As Integer
Dim Tb
 
With Worksheets("test").ChartObjects("Graphique 9").Chart
    .ChartArea.Format.Line.Transparency = 1
    Tb = .SeriesCollection(1).XValues
    For Each Pt In .SeriesCollection(1).Points
        i = i + 1
        If Tb(i) = "etalon" Then
            Pt.Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
            Exit For
        End If
    Next Pt
End With
End Sub

16/01/2013, 22h41
gaston64

Merci cela fonctionne!
17/01/2013, 19h55
gaston64
rebonjour mercatog

lorsque la série étalon se trouve en première position la macro ne permet pas de colorier le fond de la série.

j'ai essayé avec
Code:

1 2 3 4 If Tb(1) = "Budget" Then Pt.Format.Fill.ForeColor.RGB = RGB(255, 0, 0) Exit For End If
... mais sans succès. Aurais-tu une solution?
17/01/2013, 20h02
mercatog

Tb(1)?

Mets ici ton code en entier

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
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
Sub histogramme()
 
Dim dimension1 As Integer
 
m = 10
debut1:
m = m + 1
If Cells(m, 1) <> "Prix classement" Then
GoTo debut1
End If
debutvertical = m
 
n = 9
debut2:
n = n + 5
If Cells(debutvertical, n) <> "" Then
GoTo debut2
End If
finhorizontale = n - 5
 
dimension1 = (finhorizontale - 14) / 5 + 1
 
ActiveSheet.ChartObjects.Delete
 
ReDim tabD(dimension1) As String
ReDim tabCumul(dimension1) As Variant
Dim i As Integer
 
x = -1
For i = 14 To finhorizontale Step (5)
 
    If cestbon = False And Cells(debutvertical - 9, 4).Value < Cells(debutvertical, i).Value Then
    x = x + 1
    tabD(x) = "Budget"
    tabCumul(x) = Cells(debutvertical - 9, 4).Value
    cestbon = True
    jj = (i - 14) / 5 + 1
    End If
 
x = x + 1
tabD(x) = Cells(2, i).Value
tabCumul(x) = Cells(debutvertical, i).Value
Next i
 
    If cestbon = False Then
    x = x + 1
    tabD(x) = "Budget"
    tabCumul(x) = Cells(debutvertical - 9, 4).Value
    cestbon = True
    jj = (i - 14) / 5 + 1
    End If
 
Set cht = ActiveSheet.ChartObjects.Add(100, 50, 1000, 400)
With cht.Chart
    Set ser = .SeriesCollection.NewSeries
    With ser
        .XValues = tabD
        .Values = tabCumul
        .Border.ColorIndex = 5
    End With
 
ActiveSheet.ChartObjects.Left = Range("A50").Left + 5
ActiveSheet.ChartObjects.Top = Range("A50").Top + 5
ActiveSheet.ChartObjects.Width = 550
ActiveSheet.ChartObjects.Height = 310
 
.SeriesCollection(1).Format.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
.SeriesCollection(1).Format.Fill.ForeColor.Brightness = 0.349999994
.ChartArea.Format.Line.Visible = False
    Tb = .SeriesCollection(1).XValues
    For Each Pt In .SeriesCollection(1).Points
 
        'If Tb(1) = "Budget" Then
        '    Pt.Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
        '    Exit For
        'End If
 
        g = g + 1
        If Tb(g) = "Budget" Then
            Pt.Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
            Exit For
        End If
    Next Pt
 
    .Legend.Delete
    .SeriesCollection(1).Format.Line.Visible = msoFalse
    .Axes(xlCategory).TickLabels.Orientation = 30
 
End With
 
End Sub

17/01/2013, 20h21
mercatog

Désolé, on devrait faire de l'ordre dans ton code avec une organisation rigoureuse.
Si tu as un fichier exemple fidèle à l'original est sans données personnelles, ça serait l'idéal.
17/01/2013, 20h35
gaston64

1 pièce(s) jointe(s)

ci-joint le fichier

Ton code réorganisé en retour

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
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
Option Explicit
 
Const Feuille As String = "test"                   'Nom de la feuille, à adapter
Sub Histogramme()
Dim FinH As Integer, Dim1 As Integer, i As Integer, j As Integer, k As Integer
Dim TabCumul() As Double
Dim Cht As ChartObject
Dim TabD() As String
Dim Flag As Boolean
Dim DebutV As Long
Dim c As Range
 
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets(Feuille)
    If .ChartObjects.Count > 0 Then .ChartObjects.Delete
    Set c = .Range("A:A").Find("test", LookIn:=xlValues, lookat:=xlPart)
    If Not c Is Nothing Then
        DebutV = c.Row
        Set c = Nothing
        FinH = .Cells(DebutV, .Columns.Count).End(xlToLeft).Column
        Dim1 = 1 + (FinH - 14) / 5
 
        ReDim TabD(0 To Dim1)
        ReDim TabCumul(0 To Dim1)
        For i = 14 To FinH Step 5
            If Not Flag And .Cells(DebutV - 9, 11).Value < .Cells(DebutV, i).Value Then
                TabD(j) = "etalon"
                TabCumul(j) = .Cells(DebutV - 9, 11).Value
                Flag = True
                j = j + 1
                k = j
            End If
            TabD(j) = .Cells(2, i).Value
            TabCumul(j) = .Cells(DebutV, i).Value
            j = j + 1
        Next i
 
        If Not Flag Then
            TabD(j) = "etalon"
            TabCumul(j) = .Cells(DebutV - 9, 11).Value
            k = j + 1
        End If
 
        Set Cht = .ChartObjects.Add(.Range("A50").Left + 5, .Range("A50").Top + 5, 550, 310)
        With Cht.Chart
            .Legend.Delete
            .ChartArea.Format.Line.Visible = False
            .Axes(xlCategory).TickLabels.Orientation = 30
 
            With .SeriesCollection.NewSeries
                .XValues = TabD
                .Values = TabCumul
                .Border.ColorIndex = 5
                With .Format
                    With .Fill.ForeColor
                        .ObjectThemeColor = msoThemeColorText1
                        .Brightness = 0.349999994
                    End With
                    .Line.Visible = msoFalse
                End With
                .Points(k).Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
            End With
        End With
        Set Cht = Nothing
    End If
End With
End Sub

17/01/2013, 23h45
gaston64

Merci pour les corrections

Dans mon ancien code je parvenait à ne pas tenir compte des modules vides en limitant le champ des références horizontalement.

Dans ton code les modules vides sont pris en compte et apparaissent dans le graphique.

je peux adapter le code avec mon ancienne solution, cela fonctionnerait.
Mais peut être as-tu une autre solution plus "conforme" à ton code.

Merci
18/01/2013, 10h10
mercatog

Qu'entends-tu par module vide?
Sur ton fichier, je ne vois pas de quoi tu parles. déjà il me fallait un temps énorme pour comprendre un minimum de choses.
18/01/2013, 10h18
gaston64
En fait lorsque la valeur de la série est nulle il ne faudrait pas qu'elle figure sur le graphique.

Dans mon fichier j'avais règlé le problème par:
Code:

1 2 3 4 5 6 7 n = 9 debut2: n = n + 5 If Cells(debutvertical, n) <> "" Then GoTo debut2 End If finhorizontale = n - 5
je m'étais dis que tu que peut-être tu aurais une autre solution à proposer, puisque tu as changé ce morceau de code dans ton fichier.
18/01/2013, 10h30
mercatog

C'est à dire, tu t'arrêtes à la première cellule vide de la ligne 57. c'est ça?
Après cette cellules, tu pourras avoir des données?
18/01/2013, 10h55
gaston64

Oui il peut y avoir du texte après
Oui il s'agit de la première cellule vide de la ligne 57 à partir de la colonne K

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
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
Option Explicit
 
Const Feuille As String = "test"                 'Nom de la feuille, à adapter
 
Sub Histogramme()
Dim FinH As Integer, Dim1 As Integer, i As Integer, j As Integer, k As Integer
Dim TabCumul() As Double, Etalon As Double
Dim Cht As ChartObject
Dim TabD() As String
Dim Flag As Boolean
Dim DebutV As Long
Dim c As Range
 
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets(Feuille)
    If .ChartObjects.Count > 0 Then .ChartObjects.Delete
    Set c = .Range("A:A").Find("test", LookIn:=xlValues, lookat:=xlPart)
    If Not c Is Nothing Then
        DebutV = c.Row
        Set c = Nothing
        For i = 14 To .Columns.Count Step 5
            If .Cells(DebutV, i).Value = "" Then Exit For
        Next i
        FinH = i - 5
        Dim1 = 1 + (FinH - 14) / 5
 
        ReDim TabD(0 To Dim1)
        ReDim TabCumul(0 To Dim1)
        Etalon = .Cells(DebutV - 9, 11).Value
        For i = 14 To FinH Step 5
            If Not Flag And .Cells(DebutV, i).Value > Etalon Then
                TabD(j) = "Etalon"
                TabCumul(j) = Etalon
                Flag = True
                j = j + 1
                k = j
            End If
            TabD(j) = .Cells(2, i).Value
            TabCumul(j) = .Cells(DebutV, i).Value
            j = j + 1
        Next i
 
        If Not Flag Then
            TabD(j) = "Etalon"
            TabCumul(j) = Etalon
            k = j + 1
        End If
 
        Set Cht = .ChartObjects.Add(.Range("A50").Left + 5, .Range("A50").Top + 5, 550, 310)
        With Cht.Chart
            .Legend.Delete
            .ChartArea.Format.Line.Visible = False
            .Axes(xlCategory).TickLabels.Orientation = 30
 
            With .SeriesCollection.NewSeries
                .XValues = TabD
                .Values = TabCumul
                .Border.ColorIndex = 5
                With .Format
                    With .Fill.ForeColor
                        .ObjectThemeColor = msoThemeColorText1
                        .Brightness = 0.35
                    End With
                    .Line.Visible = msoFalse
                End With
                .Points(k).Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
            End With
        End With
        Set Cht = Nothing
    End If
End With
End Sub