Copier/coller Graphique avec prise en compte d'une nouvelle plage de cellule

[suistrop]

Bonjour,

Je souhaite pouvoir copier/coller des graphiques dans le meme onglets.
Je souhaite que ces graphiques prennent directement les données à l'endroit ou je le colle, de la meme manière que si je faisait un couper/coller.

Voir l'expemple en piece jointe.
Comment faire pour copier la zone fluo dans les autres zone ci dessous en ayant les nouveau graphique qui point sur la plage de donnée juste au dessus.

Merci !

==> Le but in fine est d'avoir un template et de pouvoir l'utiliser en copier collant ou je le souhaite.

 

[job75]

Re : Copier/coller Graphique avec prise en compte d'une nouvelle plage de cellule

Bonjour suistrop,

La macro en Feuil1 du fichier joint :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim co As ChartObject, t
If Target.Column = 2 And Target.Row >= 15 And (Target.Row - 15) Mod 13 = 0 Then
  Cancel = True
  For Each co In ChartObjects
    If co.TopLeftCell.Address = Target(4).Address Then co.Delete: Exit For
  Next
  t = Target.Resize(4, 8)
  [B2:I13].Copy Target
  Target.Resize(4, 8) = t
  For Each co In ChartObjects
    If co.TopLeftCell.Address = Target(4).Address Then Exit For
  Next
  co.Chart.SeriesCollection(1).XValues = Target(1, 2).Resize(, 7)
  co.Chart.SeriesCollection(1).Name = Target(2)
  co.Chart.SeriesCollection(1).Values = Target(2, 2).Resize(, 7)
  co.Chart.SeriesCollection(2).Name = Target(3)
  co.Chart.SeriesCollection(2).Values = Target(3, 2).Resize(, 7)
End If
End Sub

Double-clic en B15-B28-B41 etc... pour créer les graphiques.

A+

 

[job75]

Re : Copier/coller Graphique avec prise en compte d'une nouvelle plage de cellule

Re,

Une solution qui a l'avantage de fonctionner quel que soit le type de graphique :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim co As ChartObject, t
If Target.Column = 2 And Target.Row >= 15 And (Target.Row - 15) Mod 13 = 0 Then
  Cancel = True
  Application.ScreenUpdating = False
  For Each co In ChartObjects
    If co.TopLeftCell.Address = Target(4).Address Then co.Delete: Exit For
  Next
  t = Target.Resize(4, 8)
  Me.Copy 'nouveau document
  ActiveSheet.[B2:I13].Cut Target 'couper-coller
  ActiveWorkbook.Close False
  Target.Resize(4, 8) = t
End If
End Sub

Elle est vraiment très simple, c'est celle qu'il faut retenir.

Fichier (2).

A+

 

[suistrop]

Re : Copier/coller Graphique avec prise en compte d'une nouvelle plage de cellule

Bonjour Job75,

Merci pour ta réponse, le truc qui m’embête est que ca m'oblige à passer par un classeur intermédiaire(à cause du couper/coller) :/
J'aurais bien aimé que tout se passe dans un seul classeur !

Cordialement,

 

[job75]

Re : Copier/coller Graphique avec prise en compte d'une nouvelle plage de cellule

Re,

Ben utilise ma 1ère solution...

Bonne fin de soirée.

 

[job75]

Re : Copier/coller Graphique avec prise en compte d'une nouvelle plage de cellule

Re,

En créant une nouvelle feuille on ne sort pas du classeur :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim co As ChartObject, t
If Target.Column = 2 And Target.Row >= 15 And (Target.Row - 15) Mod 13 = 0 Then
  Cancel = True
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  For Each co In ChartObjects
    If co.TopLeftCell.Address = Target(4).Address Then co.Delete: Exit For
  Next
  t = Target.Resize(4, 8)
  Me.Copy Before:=Me 'nouvelle feuille
  ActiveSheet.[B2:I13].Cut Target 'couper-coller
  ActiveSheet.Delete
  Target.Resize(4, 8) = t
End If
End Sub

Fichier (3).

Re-bonne fin de soirée.

 

[suistrop]

Re : Copier/coller Graphique avec prise en compte d'une nouvelle plage de cellule

Salut Job75,

Ouai j'aime bien la solution du nouvel onglet !
Je prends celle ci.

Cordialement,