XL 2016 Exporter Graphique sur nouveau classeur

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

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

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

Option Explicit

Sub exporter_selection()
    ' --- DÉCLARATION DES VARIABLES (Tout au début pour Option Explicit) ---
    Dim chrt As ChartObject
    Dim choix As Variant
    Dim sFormula As String
    Dim arrParts As Variant
    Dim rngData As Range
    Dim wbNew As Workbook
   
    ' Variables pour l'Option 1
    Dim rngX As Range, rngY As Range
   
    ' Variables pour l'Option 2
    Dim strAddress As String
    Dim rngAnchor As Range
    ' ---------------------------------------------------------------------

    ' 1. Vérifier si un graphique est sélectionné
    On Error Resume Next
    Set chrt = ActiveChart.Parent
    On Error GoTo 0
   
    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) ---
        chrt.CopyPicture Appearance:=xlScreen, Format:=xlPicture
        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, ",")
       
        ' ***************************************************************************************
        ' Option 1 ci-dessous (Désactivée) :
        ' Copie SEULEMENT les données liées au graphique (X et Y précis)
        ' Pour activer : Enlevez les apostrophes ' devant les lignes de cette section
        ' et mettez des apostrophes devant l'Option 2
        ' ***************************************************************************************
       
        'Set rngX = Nothing
        'Set rngY = Nothing
       
        'If UBound(arrParts) >= 2 Then
        '    Set rngY = Range(Replace(Replace(arrParts(2), "=", ""), "'", ""))
        'End If
       
        '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
        '    rngData.Copy
        '    Set wbNew = Workbooks.Add
        '    ActiveSheet.Paste Destination:=ActiveSheet.Range("A1")
        '    ActiveSheet.Columns.AutoFit
        '    Application.ScreenUpdating = True
        '    MsgBox "Données du graphique copiées !", 64
        'Else
        '    MsgBox "Impossible de déterminer la source des données.", 16
        'End If

        ' ***************************************************************************************
        ' Option 2 ci-dessous (Activée) :
        ' Copie l'ENSEMBLE du tableau (CurrentRegion) autour des données du graphique
        ' ***************************************************************************************
       
        If UBound(arrParts) >= 2 Then
            ' Nettoyage de l'adresse Y (ex: Tableaux!$B$12)
            strAddress = Replace(Replace(arrParts(2), "=", ""), "'", "")
           
            ' Création du point d'ancrage
            Set rngAnchor = Range(strAddress)
           
            ' Astuce : CurrentRegion prend tout le tableau autour
            Set rngData = rngAnchor.CurrentRegion
           
            ' Copie vers nouveau classeur
            Application.ScreenUpdating = False
            rngData.Copy
            Set wbNew = Workbooks.Add
            ActiveSheet.Paste Destination:=ActiveSheet.Range("A1")
            ActiveSheet.Columns.AutoFit
            Application.ScreenUpdating = True
           
            MsgBox "La table de données COMPLÈTE a été copiée !", 64
        Else
            MsgBox "Impossible de déterminer la source des données.", 16
        End If
       
        On Error GoTo 0
    End If
End Sub