Ameliorer code VBA creation graphique

Version imprimable

Bonjour a tous,

j'ai besoin de faire une macro pour creer un graphique. J'ai utiliser l'assistant macro d'excel, mais ca me fait un tres gros code (je trouve).
J'aurai besoin d'aide pour l'ameliorer et l'epurer :

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
Sub Makro1()
 
    Charts.Add
    ActiveChart.ChartType = xlLineMarkers
    ActiveChart.SetSourceData Source:=Sheets("Graph").Range("F5")
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.SeriesCollection(1).XValues = _
        "='Graphikgrundlag. techn. Fortsch'!R6C3:R6C28"
    ActiveChart.SeriesCollection(1).Values = _
        "='Graphikgrundlag. techn. Fortsch'!R7C3:R7C22"
    ActiveChart.SeriesCollection(1).Name = "=""IST"""
    ActiveChart.SeriesCollection(2).Values = _
        "='Graphikgrundlag. techn. Fortsch'!R8C3:R8C24"
    ActiveChart.SeriesCollection(2).Name = "=""Soll"""
    ActiveChart.SeriesCollection(3).Values = _
        "='Graphikgrundlag. techn. Fortsch'!R9C3:R9C28"
    ActiveChart.SeriesCollection(3).Name = "=""Anbindung"""
    ActiveChart.Location Where:=xlLocationAsObject, Name:="Graph"
    ActiveChart.Axes(xlValue).MajorGridlines.Select
    ActiveChart.SeriesCollection(1).Select
    ActiveChart.SeriesCollection(1).ChartType = xlColumnClustered
End Sub

Par exemple, j'aimerai que les plages de valeurs pour les courbes en ordonnes ne soit pas fixe mais que ca aille chercher les valeurs jusqu'a la premiere case vide.

Merci d'avance pour votre aide.

J'ai trouve un bout de code que j'ai essaye d'adapter a mon cas, mais pour le moment cela ne fonctionne pas (erreur de compilation au niveau du with graphik).

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
Sub Courbe()
 
Dim FSGraph As Chart, Graphik As Worksheet, Donnees As Range
Dim PlageX As Range, PlageY As Range, MaSerie As Series, cmpt As Long
 
Set Graphik = Worksheets("Graphikgrundlag. techn. Fortsch")
 
With Graphik
    Set Donnees = .Range(.Cells(6, 3), .Cells(6, 3).End(xlRight)).Resize(9, 0)
End With
 
Set FSGraph = ThisWorkbook.Charts.Add
    FSGraph.ChartArea.Clear
    FSGraph.ChartType = xlXYScatter
 
Set PlageX = Donnees.Rows(1)
 
For cmpt = 1 To Donnees.Rows.Count - 1
    Set PlageY = PlageX.Offset(cmpt, 0)
    Set MaSerie = FSGraph.SeriesCollection.Newserie
 
    With MaSerie
        .Values = PlageY
        .XValues = PlageX
        .Name = Donnees.Cells(6, 3).Offset(compteur, -1)
    End With
Next cmpt

Vu que j'arrive pas a resoudre le probleme j'ai un peu simplifie le code, mais j'ai maintenant une erreur au niveau du
Set MaSerie = FSGraph.SeriesCollection.NewSeries

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
Dim FSGraph As Chart, Graphik As Worksheet, Donnees As Range
Dim PlageX As Range, PlageY As Range, MaSerie As Series, cmpt As Long
 
Set Graphik = Worksheets("Graphikgrundlag. techn. Fortsch")
 
With Graphik
    Set Donnees = .Range(.Cells(6, 3), .Cells(9, 10))
End With
 
Set FSGraph = ThisWorkbook.Charts.Add
    FSGraph.ChartArea.Clear
    FSGraph.ChartType = xlXYScatter
 
Set PlageX = Range("C6:J6")
 
For cmpt = 1 To 3
    Set PlageY = PlageX.Offset(cmpt, 0)
    Set MaSerie = FSGraph.SeriesCollection.NewSeries
 
    With MaSerie
        .Values = PlageY
        .XValues = PlageX
        .Name = Donnees.Cells(6, 3).Offset(compteur, -1)
    End With
Next cmpt

Bonjour

A force de tatonnements jai trouvé.

pour ce code il faut que tu mette le nom des séries a gauche de tes valeurs en cellule B7, B8 et B9.

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
 
Sub Courbe()
 
Dim FSGraph As Chart, Graphik As Worksheet, Donnees As Range
Dim PlageX As Range, PlageY As Range, MaSerie As Series, cmpt As Long
 
Set Graphik = Worksheets("Graphikgrundlag. techn. Fortsch")
 
With Graphik
    Set Donnees = .Range(.Cells(6, 3), .Cells(9, .Cells(6, 3).End(xlToRight).Column))
End With
 
Set FSGraph = ThisWorkbook.Charts.Add
    FSGraph.ChartArea.Clear
    FSGraph.ChartType = xlXYScatter
 
Set PlageX = Donnees.Rows(1)
 
For cmpt = 1 To Donnees.Rows.Count - 1
    Set PlageY = PlageX.Offset(cmpt, 0)
    Set MaSerie = FSGraph.SeriesCollection.NewSeries
 
    With MaSerie
        .Values = PlageY
        .XValues = PlageX
    End With
    FSGraph.SeriesCollection(cmpt).Name = "=""" & Graphik.Range(Donnees.Cells(cmpt + 1, 0).Address).Value & """"
Next cmpt
FSGraph.SeriesCollection(1).ChartType = xlColumnClustered
FSGraph.Location Where:=xlLocationAsObject, Name:="Graph"
End Sub

30/06/2010, 11h54
Potzo

1 pièce(s) jointe(s)

Merci pour cette reponse. Malheureusement, il doit y avoir quelques soucis de compatibilite avec ce que je veux faire.

Il n'y a pas de soucis au niveau de la compilation, nais lorsque le graphe sort, mon axe des abscisses etant une succession de date, elles ne sortent pas correctement et au niveau de valeurs elles sont toutes sur une seule abscisse.

Je joins mon fichier pour que ce soit plus clair.

Bonjour

j'ai regardé ton fichier et le problème viens des dates, je ne connais pas assez les graphs pour en connaitre la raison mais j'ai trouvé un paliatif en ajoutant 2 boucles, la premiere en début de code pour remplacer les dates en texte et l'autre à la fin pour faire l'inverse.

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
 
Sub Courbe()
 
Dim FSGraph As Chart, Graphik As Worksheet, Donnees As Range
Dim PlageX As Range, PlageY As Range, MaSerie As Series, cmpt As Long
 
Set Graphik = Worksheets("Graphikgrundlag. techn. Fortsch")
 
' # Boucle pour transformer les date en texte
For Each PlageX In Graphik.Range(Graphik.Cells(6, 3), Graphik.Cells(6, Graphik.Cells(6, 3).End(xlToRight).Column))
    PlageX = "'" & Format(PlageX.Value, "mmm-yy")
Next
 
With Graphik
    Set Donnees = .Range(.Cells(6, 3), .Cells(9, .Cells(6, 3).End(xlToRight).Column))
End With
 
Set FSGraph = ThisWorkbook.Charts.Add
    FSGraph.ChartArea.Clear
    FSGraph.ChartType = xlXYScatter
 
Set PlageX = Donnees.Rows(1)
 
For cmpt = 1 To Donnees.Rows.Count - 1
    Set PlageY = PlageX.Offset(cmpt, 0)
    Set MaSerie = FSGraph.SeriesCollection.NewSeries
 
    With MaSerie
        .Values = PlageY
        .XValues = PlageX
    End With
    FSGraph.SeriesCollection(cmpt).Name = "=""" & Graphik.Range(Donnees.Cells(cmpt + 1, 0).Address).Value & """"
Next cmpt
FSGraph.SeriesCollection(1).ChartType = xlColumnClustered
FSGraph.Location Where:=xlLocationAsObject, Name:="Graph"
 
' # Boucle pour remettre les dates
For Each PlageX In Graphik.Range(Graphik.Cells(6, 3), Graphik.Cells(6, Graphik.Cells(6, 3).End(xlToRight).Column))
    PlageX = Replace(PlageX.Value, "'", "")
Next
End Sub

01/07/2010, 09h12
Potzo

Ca marche super !

Merci beaucoup Zyhack. :D