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

 

[Nain porte quoi]

Hello,

c'est quoi que vous voulez exporter ? La feuille ou les objets graphiques ?
Si vous voulez exportez les graphiques seuls ça sera alors des images figées ou alors ils seront liés au classeur de base car je ne vois pas comment exporter un graphique sans sa source

 

[KTM]

Hello,

c'est quoi que vous voulez exporter ? La feuille ou les objets graphiques ?
Si vous voulez exportez les graphiques seuls ça sera alors des images figées ou alors ils seront liés au classeur de base car je ne vois pas comment exporter un graphique sans sa source

l'export se fera soit le Graphique (image) copié sur un classeur soit la table copiée sur un classeur
Merci d'avance...

 

[Nain porte quoi]

OK, ça devrait donc ressembler à ça

Option Explicit

Sub exporter()
   
    Dim choix
    If MsgBox("Exporter ? ", vbYesNo + vbQuestion, "Exportation") = vbNo Then Exit Sub
    choix = InputBox("Données à Copier: " & vbCrLf & _
    "  1- Graphique" & vbCrLf & _
    "  2- Base de Données", "Exportation")
   
    If choix = "" Then Exit Sub
    If Not IsNumeric(choix) Or choix < 1 Or choix > 2 Then
        MsgBox " Mauvais Choix ", vbExclamation, "Erreur"
        Exit Sub
    Else
        ' récupère le nom du bouton cliqué
        Dim Nom_Objet As String
        Nom_Objet = Right(Application.Caller, 3)
       
        If choix = 1 Then
            'Exporter Graphique
            Dim Nom_Graph As String
            Nom_Graph = "Graphe_" & Nom_Objet
            Sheets("Graph").ChartObjects(Nom_Graph).Copy
            Workbooks.Add
            ActiveSheet.Pictures.Paste
        Else
            'Exporter les données du graphique
            Dim Nom_Data As String
            Nom_Data = "Data_" & Right(Application.Caller, 3)
            Sheets("Tableaux").Range(Nom_Data).Copy
            Workbooks.Add
            ActiveSheet.Paste
            Application.CutCopyMode = False
        End If
    End If

End Sub

A noter que j'ai nommé les graphes, les boutons et les zones de données (et légèrement modifié votre code)

 

[job75]

Bonsoir KTM, Nain porte quoi,

Une solution très simple mais pas sûr que KTM sera content :

Sub Exporter()
Dim choix$
choix = InputBox("Données à Copier: " & vbCrLf & _
"  1- Graphique" & vbCrLf & _
"  2- Base de Données", "Exportation")
If IsError(Application.Match(choix, Array("1", "2"), 0)) Then Exit Sub
Application.ScreenUpdating = False
Sheets(IIf(choix = 1, "Graph", "Tableaux")).ExportAsFixedFormat xlTypePDF, ThisWorkbook.Path & "\" & IIf(choix = 1, "Graph.pdf", "Tableaux.pdf")
End Sub

A+

 

[laurent950]

Bonsoir KTM, @job75 , N'importe quoi

Option Explicit

Sub exporter_selection()
    Dim chrt As ChartObject
    Dim choix As Variant
    Dim sFormula As String
    Dim arrParts As Variant
    Dim rngData As Range
    Dim wbNew As Workbook
 
    ' 1. Vérifier si un graphique est sélectionné
    On Error Resume Next
    ' On essaie de récupérer le graphique actif via son parent (l'objet graphique)
    Set chrt = ActiveChart.Parent
    On Error GoTo 0
 
    ' Si chrt est vide (Nothing), c'est que l'utilisateur n'a pas cliqué sur un graphique
    If chrt Is Nothing Then
        MsgBox "Veuillez d'abord SÉLECTIONNER le graphique souhaité en cliquant dessus," & vbCrLf & _
               "puis cliquez sur le bouton d'exportation.", 48, "Aucune sélection"
        Exit Sub
    End If

    ' 2. Demande à l'utilisateur
    choix = InputBox("Données à Copier pour le graphique : " & chrt.Name & Chr(10) & Chr(13) & _
                     "  1- Graphique (Image)" & 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
    End If

    ' 3. Exécution du choix
    If choix = 1 Then
        ' --- CAS 1 : EXPORTER LE GRAPHIQUE (IMAGE) ---
        ' On copie l'image du graphique sélectionné
        chrt.CopyPicture Appearance:=xlScreen, Format:=xlPicture
     
        ' Nouveau classeur
        Set wbNew = Workbooks.Add
        ActiveSheet.Paste
        MsgBox "Graphique copié dans un nouveau classeur !", 64
     
    ElseIf choix = 2 Then
        ' --- CAS 2 : EXPORTER LES DONNÉES ---
        On Error Resume Next
     
        ' Récupérer la formule de la série
        sFormula = chrt.Chart.SeriesCollection(1).Formula
        arrParts = Split(sFormula, ",")
     
        Dim rngX As Range, rngY As Range
        Set rngX = Nothing
        Set rngY = Nothing
     
        ' Récupérer la plage Y (Données)
        If UBound(arrParts) >= 2 Then
            Set rngY = Range(Replace(Replace(arrParts(2), "=", ""), "'", ""))
        End If
     
        ' Récupérer la plage X (Libellés)
        If UBound(arrParts) >= 1 And Trim(arrParts(1)) <> "" Then
            Set rngX = Range(Replace(Replace(arrParts(1), "=", ""), "'", ""))
        End If
     
        If Not rngY Is Nothing Then
            Application.ScreenUpdating = False
         
            If Not rngX Is Nothing Then
                Set rngData = Union(rngX, rngY)
            Else
                Set rngData = rngY
            End If
         
            ' Copier vers nouveau classeur
            rngData.Copy
            Set wbNew = Workbooks.Add
            ActiveSheet.Paste Destination:=ActiveSheet.Range("A1")
            ActiveSheet.Columns.AutoFit
            Application.ScreenUpdating = True
         
            MsgBox "Données copiées dans un nouveau classeur !", 64
        Else
            MsgBox "Impossible de déterminer la source des données.", 16
        End If
        On Error GoTo 0
    End If
End Sub