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
