Je suis en train de me faire une petite macro qui permet de créer un graphique réunissant toutes les courbes de tous les graphiques présents sur ma feuille Excel. Les couleurs et les styles sont gardés.
Par contre je ne m'occupe pas des titres et de la légende pcq ça va vite être le bordel.
La macro marche pas mal pour les graphiques de type XY mais j'aimerais bien que ça marche pour les autres types (histoire de peaufiner un peu c'est tout, car je me trouve rarement dans un autre cas de figure).
La meilleure solution je pense est de copier l'objet ActiveSheet.ChartObjects(i).Chart.SeriesCollection(j) et l'ajouter dans ActiveChart.SeriesCollection mais je me suis cassé les dents.
-> Copy/Paste plante à l'appel de Copy
-> Set ... = ... plante aussi
-> Faire une fonction MyCopyProc(ByRef dst, ByVal src) { Set dst = src } ne plante pas mais ne marche pas
..... ARF !
Du coup je fait une copie élément par élément de l'objet (et qui est non exhaustive) comme vous pouvez le constater dans la source présentée ci-jointe ...
Quelqu'un aurait-il une idée ??
Voilà mon code, qui marche quand même pour ceux qui sont intéressés.
Merci !
YD
'#------------------------------------------------------#
'# Macro enregistrée par YDouvry le 01/04/2009 #
'#------------------------------------------------------#
Sub Merge_Graph()
Dim i As Integer, j As Integer
Dim sheet_name As String
sheet_name = ActiveSheet.Name
Dim chart_count As Integer
chart_count = ActiveSheet.ChartObjects.Count
Dim tmp As Object
Dim xmin As Double, xmax As Double, ymin As Double, ymax As Double
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=sheet_name
With ActiveChart
.ChartArea.AutoScaleFont = False
.ChartType = xlXYScatterSmoothNoMarkers
Do Until .SeriesCollection.Count = 0
.SeriesCollection(1).Delete
Loop
With .Parent
.Width = 300
.Height = 200
.Left = 0
.Top = 0
End With
Application.ScreenUpdating = False
For i = 1 To chart_count
Set tmp = ActiveSheet.ChartObjects(i).Chart.SeriesCollection
For j = 1 To tmp.Count
With .SeriesCollection.NewSeries
.AxisGroup = tmp(j).AxisGroup
.BarShape = tmp(j).BarShape
.Border.Weight = tmp(j).Border.Weight
.Border.LineStyle = tmp(j).Border.LineStyle
.Border.color = tmp(j).Border.color
.ChartType = tmp(j).ChartType
.Formula = tmp(j).Formula
.Has3DEffect = tmp(j).Has3DEffect
If .Has3DEffect Then
.ApplyPictToEnd = tmp(j).ApplyPictToEnd
.ApplyPictToFront = tmp(j).ApplyPictToFront
.ApplyPictToSides = tmp(j).ApplyPictToSides
End If
.HasDataLabels = tmp(j).HasDataLabels
.HasErrorBars = tmp(j).HasErrorBars
If .HasErrorBars Then
.ErrorBars.EndStyle = tmp(j).ErrorBars.EndStyle
.ErrorBars.Border.LineStyle = tmp(j).ErrorBars.Border.LineStyle
.ErrorBars.Border.Weight = tmp(j).ErrorBars.Border.Weight
.ErrorBars.Border.color = tmp(j).ErrorBars.Border.color
End If
.HasLeaderLines = tmp(j).HasLeaderLines
.MarkerBackgroundColor = tmp(j).MarkerBackgroundColor
.MarkerForegroundColor = tmp(j).MarkerForegroundColor
.MarkerSize = tmp(j).MarkerSize
.MarkerStyle = tmp(j).MarkerStyle
.Name = tmp(j).Name
.Shadow = tmp(j).Shadow
.Smooth = tmp(j).Smooth
.Type = tmp(j).Type
End With
Next
Set tmp = ActiveSheet.ChartObjects(i).Chart
If i = 1 Then
xmin = tmp.Axes(xlCategory).MinimumScale
xmax = tmp.Axes(xlCategory).MaximumScale
ymin = tmp.Axes(xlValue).MinimumScale
ymax = tmp.Axes(xlValue).MaximumScale
Else
xmin = Min(xmin, tmp.Axes(xlCategory).MinimumScale)
xmax = Max(xmax, tmp.Axes(xlCategory).MaximumScale)
ymin = Min(ymin, tmp.Axes(xlValue).MinimumScale)
ymax = Max(ymax, tmp.Axes(xlValue).MaximumScale)
End If
Next
Set tmp = Nothing
.Axes(xlCategory).MinimumScale = xmin
.Axes(xlCategory).MaximumScale = xmax
.Axes(xlValue).MinimumScale = ymin
.Axes(xlValue).MaximumScale = ymax
.HasTitle = True
.Axes(xlCategory).HasTitle = True
.Axes(xlValue).HasTitle = True
.HasLegend = False
.ChartTitle.Text = "Text"
.Axes(xlCategory).AxisTitle.Characters.Text = "VDS (V)"
.Axes(xlValue).AxisTitle.Characters.Text = "ID (A/mm)"
Application.ScreenUpdating = True
With .PlotArea
.Left = 5
.Top = 10
.Height = ActiveChart.Parent.Height - 15
.Width = ActiveChart.Parent.Width - 10
End With
With .ChartTitle
.Font.Bold = True
.Font.Size = 11
.Top = 0
End With
With .Axes(xlCategory)
'.CrossesAt = .MinimumScale
.TickLabels.Font.Size = 10
With .AxisTitle
.Top = ActiveChart.Parent.Height - 50
.Left = ActiveChart.Parent.Width - 60
.Font.Bold = True
.Font.Size = 10
.Characters(2, 2).Font.Subscript = True
End With
End With
With .Axes(xlValue)
'.CrossesAt = .MinimumScale
.TickLabels.Font.Size = 10
With .AxisTitle
.Orientation = xlHorizontal
.Top = 0
.Left = 30
.Font.Bold = True
.Font.Size = 10
.Characters(2, 1).Font.Subscript = True
End With
End With
End With
End Sub
Oups, j'ai oublié les fonctions Min et Max à ajouter dans le module :
Private Function Min(x As Double, y As Double) As Double
If x < y Then Min = x Else Min = y
End Function
Private Function Max(x As Double, y As Double) As Double
If x > y Then Max = x Else Max = y
End Function
Pour donner plus de précision sur la méthode MyCopyProc qui n'a pas marché :
Public Sub MyCopyProc(ByRef dst as Object, ByVal src as Object)
Set dst = src
End Sub
