XL 2016 Exporter Graphique sur nouveau classeur

[KTM]

Bonjour chers tous
Jai un fichier sur lequel jai une feuille qui contient les tables de données et une feuille sur laquelle les graphiques afférents sont construits.
Jai associé un bouton à chaque graphique qui offre le choix entre copier le graphique sur un nouveau classeur et copier seulement la table de données liée au graphique.

Jai fait un début de macro et je sollicite votre aide pour finir le paramétrage merci..

Sub exporter()

Dim choix
If MsgBox("Exporter ? ", vbYesNo + 32) = vbNo Then Exit Sub
choix = InputBox("Données à Copier: " & Chr(10) & Chr(13) & _
"  1- Graphique" & Chr(10) & Chr(13) & _
"  2- Base de Données", "Exportation")

If choix = "" Then
Exit Sub
ElseIf Not IsNumeric(choix) Or choix < 1 Or choix > 2 Then
MsgBox " Mauvais Choix ", 48
Exit Sub
Else
    If choix = 1 Then
    'Exporter Graphique
    ElseIf choix = 2 Then
    'Exporter les données du graphique
    End If
End If
End Sub

 

[laurent950]

Bonsoir @job75

Sub Export()
Dim FeuilSource As Worksheet
    Set FeuilSource = ThisWorkbook.Worksheets(ActiveSheet.Name)
Dim colRefs As New Collection
 ' Les données Stoké en Static dans la FeuilSource Excel : Formule / Gestionaire de nom
    colRefs.Add Key:="BCG Graph", Item:=FeuilSource.Range("A2:F16")
    colRefs.Add Key:="BCG Tableau", Item:=FeuilSource.Range("A3:C8")
    colRefs.Add Key:="VAR Graph", Item:=FeuilSource.Range("A17:F31")
    colRefs.Add Key:="VAR Tableau", Item:=FeuilSource.Range("A11:C16")
Dim rngSource As Range
    Set rngSource = colRefs(CStr(ActiveSheet.DrawingObjects(Application.Caller).Text))
With Workbooks.Add(xlWBATWorksheet) 'feuille de calcul
    .Sheets(1).Name = FeuilSource.Name
     rngSource.Copy Destination:=.Sheets(1).[A1] 'copier-coller
    .UpdateLinks = xlUpdateLinksAlways 'évite le message de mise à jour des liens à l'ouverture
    .SaveAs ThisWorkbook.Path & "\" & FeuilSource.Name & ".xlsx"
    .Close
End With
MsgBox "Le fichier '" & FeuilSource.Name & ".xlsx' a été créé..."
End Sub

 

[job75]

Bonsoir Laurent,

Pourquoi une collection ? Nommer les plages est quand même plus simple non ?

A+

 

[laurent950]

Bonsoir @job75,

L’idée était de rendre cela dynamique, via un événement au clic sur le graphique, afin d’éviter de recopier les adresses.

Oui, on peut les nommer via des plages, etc.,

mais cela reste statique puisqu’il faut tout définir à l’avance pour que cela fonctionne.

 

[job75]

Bonjour Laurent,

L’idée était de rendre cela dynamique, via un événement au clic sur le graphique, afin d’éviter de recopier les adresses.

Il suffit d'affecter cette macro à chacun des graphiques :

Sub Export()
Dim CO As ChartObject, choix As Byte, plage As Range, nom$
With Sheets("Graph")
    Set CO = .ChartObjects(Application.Caller)
    If IsError(Application.Match(.[C1], Array(1, 2), 0)) Then .[C1] = 1
    choix = .[C1]
    If choix = 1 Then Set plage = .Range(CO.TopLeftCell, CO.BottomRightCell) _
        Else Set plage = Sheets("Tableaux").Cells.Find(CO.Name, , xlValues).CurrentRegion
End With
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Workbooks.Add(xlWBATWorksheet) 'feuille de calcul
    .Sheets(1).Name = CO.Name
    plage.Copy .Sheets(1).[A1] 'copier-coller
    .UpdateLinks = xlUpdateLinksAlways 'évite le message de mise à jour des liens à l'ouverture
    .SaveAs ThisWorkbook.Path & "\" & CO.Name & IIf(choix = 1, " Graph", " Tableau") & ".xlsx"
    nom = .Name
    .Close
End With
MsgBox "Le fichier '" & nom & "' a été créé..."
End Sub

Ici aucune plage n'est nommée.

A+

 

[laurent950]

Bonjour @job75

Il suffit d'affecter cette macro à chacun des graphiques = Contrainte soit autant d'affectation que de graphique de plus si ils sont répartie sur toutes un classeur a divers endroit.

le module de classe permet de se substitué à cette contrainte
Code a coller dans : ThisWorkbook

Option Explicit

' CE CODE EST DANS "ThisWorkbook"
Dim CollecGraphiques As Collection

Private Sub Workbook_Open()
    Dim ws As Worksheet
    Dim chrt As ChartObject
    Dim ClasseGraph As GestionGraphiques
 
    ' Initialiser la collection
    Set CollecGraphiques = New Collection
 
    ' Parcourir TOUTES les feuilles du classeur
    For Each ws In Me.Worksheets
        ' Parcourir TOUS les graphiques de chaque feuille
        For Each chrt In ws.ChartObjects
            ' Créer une nouvelle instance de notre classe
            Set ClasseGraph = New GestionGraphiques
            ' Relier le graphique détecté à la classe
            Set ClasseGraph.GraphEvent = chrt.Chart
            ' Ajouter à la collection pour garder en mémoire
            CollecGraphiques.Add ClasseGraph
        Next chrt
    Next ws
End  sub

Code a coller dans Le Module de Classe à créer lui donner ce NOM : GestionGraphiques

' CE CODE EST DANS LE MODULE DE CLASSE "GestionGraphiques"
Public WithEvents GraphEvent As Chart

' Cette procédure se déc
lenche quand on clique sur le graphique
Private Sub GraphEvent_MouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
    ' Button = 1 correspond au Clic Gauche
    If Button = 1 Then
        ' On lance votre macro d'export
        exporter_selection
    End If
End Sub

Il fonctionne aussi avec votre code ci-dessous compresser, Puis il est 100% Dynamique

Option Explicit
Sub Export(ByRef CO As Chart)
Dim strAddress, Nom
With Workbooks.Add(xlWBATWorksheet) 'feuille de calcul
    .Sheets(1).Name = CO.Parent.Parent.Name
    If CO.Parent.Parent.Cells(1, 3) = 1 Then
        CO.CopyPicture Appearance:=xlScreen, Format:=xlPicture
        ActiveSheet.Paste
    Else
        strAddress = Split(Replace(Replace(Split(Replace(CO.SeriesCollection(1).Formula, ";", ","), ",")(1), "=", ""), "'", ""), "!")
        ThisWorkbook.Worksheets(strAddress(0)).Range(strAddress(1)).CurrentRegion.Copy .Sheets(1).[A1]
    End If
    .UpdateLinks = xlUpdateLinksAlways 'évite le message de mise à jour des liens à l'ouverture
    .SaveAs ThisWorkbook.Path & "\" & CO.Name & " " & CO.Parent.Parent.Cells(1, 3) & ".xlsx"
    .Close
End With
    CO.Deselect
    MsgBox "Le fichier '" & CO.Name & " " & CO.Parent.Parent.Cells(1, 3) & "' a été créé..."
End Sub