Vous utilisez un navigateur obsolète. Il se peut que ce site ou d'autres sites Web ne s'affichent pas correctement. Vous devez le mettre à jour ou utiliser un navigateur alternatif.
Boostez vos compétences Excel avec notre communauté !
Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force.
Apprenez, échangez, progressez – et tout ça gratuitement !
👉 Inscrivez-vous maintenant !
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..
VB:
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
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
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
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)
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
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
Super !!!
cette solution répond à mes attentes ; avec le premier graphique pas de problème mais avec le deuxième graphique ya encore des détails à régler je pense.
Merci de vérifier avec le fichier joint .
Grandement merci pour l'aide...
Cette solution avec 2 boutons vous plaira peut-être davantage :
VB:
Sub Exporter()
Dim titre$, choix$, s As Boolean, nom$
titre = IIf(Application.Caller = "Graph1", "BCG", "VAR")
Do
choix = InputBox("Données à Copier : " & vbCrLf & _
" 1- Graphique" & vbCrLf & _
" 2- Base de Données", "Exporter " & titre, choix)
If choix = "" Then Exit Sub
If IsNumeric(Application.Match(choix, Array("1", "2"), 0)) Then Exit Do
Loop
Application.ScreenUpdating = False
s = ThisWorkbook.Saved 'mémorise l'état
ThisWorkbook.Names.Add "Graph", Right(Application.Caller, 1) 'nom défini pour les zones d'impression
If s Then ThisWorkbook.Saved = True 'évite l'invite à la fermeture si aucune autre modification
nom = ThisWorkbook.Path & "\" & IIf(choix = 1, "Graph " & titre, "Tableaux " & titre) & ".pdf"
Sheets(IIf(choix = 1, "Graph", "Tableaux")).ExportAsFixedFormat xlTypePDF, nom
End Sub
Il se crée 2 fichiers pour les graphiques et 2 fichiers pour les tableaux.
Avec le solution que j'ai donnée les fichiers obtenus sont des fichiers PDF.
Si l'on veut obtenir des classeurs Excel on utilisera cette macro :
VB:
Sub Exporter()
Dim titre$, choix$, plage As Range
titre = IIf(Application.Caller = "Graph1", "BCG", "VAR")
Do
choix = InputBox("Données à Copier : " & vbCrLf & _
" 1- Graphique" & vbCrLf & _
" 2- Base de Données", "Exporter " & titre, choix)
If choix = "" Then Exit Sub
If IsNumeric(Application.Match(choix, Array("1", "2"), 0)) Then Exit Do
Loop
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.CopyObjectsWithCells = True 'au cas où ce n'est pas le cas
If choix = "1" Then
Set plage = IIf(titre = "BCG", Sheets("Graph").[A2:F16], Sheets("Graph").[A17:F31])
Else
Set plage = IIf(titre = "BCG", Sheets("Tableaux").[A3:C8], Sheets("Tableaux").[A11:C16])
End If
With Workbooks.Add(xlWBATWorksheet) 'feuille de calcul
plage.Copy .Sheets(1).[A1] 'copier-coller
.UpdateLinks = xlUpdateLinksAlways 'évite le message de mise à jour des liens à l'ouverture
.SaveAs ThisWorkbook.Path & "\" & titre & IIf(choix = 1, " Graph.xlsx", " Tableaux.xlsx")
.Close
End With
End Sub
Nota : pour que les formats "Pourcentage" des graphiques soient bien copiés il faut décocher les options "Lier à la source".
Avec le solution que j'ai donnée les fichiers obtenus sont des fichiers PDF.
Si l'on veut obtenir des classeurs Excel on utilisera cette macro :
VB:
Sub Exporter()
Dim titre$, choix$, plage As Range
titre = IIf(Application.Caller = "Graph1", "BCG", "VAR")
Do
choix = InputBox("Données à Copier : " & vbCrLf & _
" 1- Graphique" & vbCrLf & _
" 2- Base de Données", "Exporter " & titre, choix)
If choix = "" Then Exit Sub
If IsNumeric(Application.Match(choix, Array("1", "2"), 0)) Then Exit Do
Loop
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.CopyObjectsWithCells = True 'au cas où ce n'est pas le cas
If choix = "1" Then
Set plage = IIf(titre = "BCG", Sheets("Graph").[A2:F16], Sheets("Graph").[A17:F31])
Else
Set plage = IIf(titre = "BCG", Sheets("Tableaux").[A3:C8], Sheets("Tableaux").[A11:C16])
End If
With Workbooks.Add(xlWBATWorksheet) 'feuille de calcul
plage.Copy .Sheets(1).[A1] 'copier-coller
.UpdateLinks = xlUpdateLinksAlways 'évite le message de mise à jour des liens à l'ouverture
.SaveAs ThisWorkbook.Path & "\" & titre & IIf(choix = 1, " Graph.xlsx", " Tableaux.xlsx")
.Close
End With
End Sub
Nota : pour que les formats "Pourcentage" des graphiques soient bien copiés il faut décocher les options "Lier à la source".
Super !!!
cette solution répond à mes attentes ; avec le premier graphique pas de problème mais avec le deuxième graphique ya encore des détails à régler je pense.
Merci de vérifier avec le fichier joint .
Grandement merci pour l'aide...
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
Code a coller dans Le Module de Classe à créer lui donner ce NOM : GestionGraphiques
Code:
' 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
Code a coller dans Module standard qui lui ne change pas en Poste #7
Code:
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
Explication : Passage d'une méthode statique à une méthode dynamique orientée objet.
Via Module de Classe "GestionGraphiques" avec événement sur Graphique
1. Associer au Graphique : ne plus ajouter de boutons sur celui-ci.
Suppression des boutons physiques superposés. Le graphique devient lui-même le déclencheur.
- Techniquement : Grâce au Module de Classe, l'événement est branché directement sur l'objet Graphique.
- Action : Un clic gauche intercepte le code (plus besoin d'intermédiaire).
2. "S'affranchir des plages fixes"
Remplacement des adresses codées en dur (ex: A2:C10) qui limitent la copie en cas d'ajout de données.
- Méthode dynamique : L'objet Graphique contient les informations de ses propres données.
- Astuce : CurrentRegion capture automatiquement tout le bloc de données continu autour.
3. Simplicité : Un clic sur le graphique et cela peu importe son emplacement
Abandon du code spécifique par feuille. La règle s'applique à tout le classeur ("Workbook").
- Techniquement : Au démarrage (Workbook_Open), le code scanne toutes les feuilles et attribue la capacité d'export à tous les graphiques.
- Résultat : Chaque graphique est indépendant et réagit au clic.
Note : Relancer le classeur (fermer/ouvrir) après chaque création de nouveau graphique.
En résumé – Architecture orientée objet :
Le graphique est dissocié de toute plage fixe ou feuille définie.
- Il devient un objet actif et autonome, porteur de ses propres données et réactif au clic gauche.
- Solution universelle, évolutive et sans maintenance requise.
Bonjour à tous,
A moins de quelques limitations obscures de VBA on pourrait meme placer exporter_selection dans le module de classe en privé pour "embrasser" les principes POO.
Belle approche en tout cas, c'est le plus robuste.
Amusant, laurent950 cherche des solutions de plus en plus compliquées et moi de plus en plus simples :
VB:
Sub Export()
Dim nom$, plage As Range
nom = ActiveSheet.DrawingObjects(Application.Caller).Text
Set plage = Evaluate(Replace(nom, " ", "_")) 'plage nommée
Application.ScreenUpdating = False
With Workbooks.Add(xlWBATWorksheet) 'feuille de calcul
.Sheets(1).Name = nom
plage.Copy .Sheets(1).[A1] 'copier-coller
.UpdateLinks = xlUpdateLinksAlways 'évite le message de mise à jour des liens à l'ouverture
.SaveAs ThisWorkbook.Path & "\" & nom & ".xlsx"
.Close
End With
MsgBox "Le fichier '" & nom & ".xlsx' a été créé..."
End Sub
- Navigue sans publicité - Accède à Cléa, notre assistante IA experte Excel... et pas que... - Profite de fonctionnalités exclusives Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel. Je deviens Supporter XLD
