[VBA/Excel] Fusion de tableau

Shinkei -  
 Shinkei -
Bonjour à toutes et à tous,

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
A voir également:

1 réponse

Réponse 1 / 1
Shinkei
 
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


... et pour l'utilisation : 
call MyCopyProc(.SeriesCollection.NewSeries, _
                        ActiveSheet.ChartObjects(i).Chart.SeriesCollection(j))

Ça fait pas d'erreur mais ça marche pas non plus comme je le voudrais...

Merci encore pour l'aide
0