XL 2016 Supprimer le graphique précédent à chaque création d'un nouveau graphique

[othmane_007_007]

Bonjour,

J'ai un soucis avec mon code, je n'arrive pas à supprimer l'ancien graphique quand je lance la création d'un nouveau graph
Ci-dessous vous trouverez mon code (j'ai utilisé enregistrement macro)

j'ai une deuxième question a vous poser : comment faire pour que le graph apparaît dans une nouvelle feuille

Bien à vous,

Othmane

Sub graphique()
    Dim Plage As Range
    Dim Lignes(), i As Long
    Dim texte As String
    Dim Flag As Boolean
    Set Plage = Sheets("Feuille de calculs").Columns(22) 'plage de recherche
    texte = "Ventilateur"   'expression cherchée
    Flag = Find_Next(Plage, texte, Lignes())  'appel de la fonction
    If Flag Then  'si fonction retourne Vrai = expression trouvée dans la plage
        For i = LBound(Lignes) To UBound(Lignes)   'restitution des lignes correspondantes
            Debug.Print Lignes(i)
            If i > 0 Then
                MsgBox "Erreur : Vous avez placé plus d'un repère." & vbCr & vbCr & "Veuillez introduire seulement un repère."
                GoTo hors
            End If
            If i = 0 Then
                Set b = Range("B13:B60")
                For c = 1 To b.Rows.Count
                    If Not IsEmpty(b.Cells(c, 1)) Then
                        Set r = Range("V13:V60")
                        For n = 1 To r.Rows.Count
                            If Not IsEmpty(r.Cells(n, 1)) Then
                                For j = 1 To n
                                    r.Cells(j, 1).Offset(0, 2).Value = 0 - r.Cells(j, 1).Offset(0, -1).Value 'pour les ordonnées
                                    r.Cells(j, 1).Offset(0, 3).Value = r.Cells(j, 1).Offset(0, 1).Value 'pour longueur donc les abscisses
                                Next j
                                r.Cells(n + 1, 1).Offset(0, 2).Value = r.Cells(j, 1).Offset(0, -1).End(xlDown).Value - r.Cells(n, 1).Offset(0, -1).Value 'pour les ordonnées
                                r.Cells(n + 1, 1).Offset(0, 3).Value = r.Cells(n, 1).Offset(0, 1).Value 'pour longueur donc les abscisses
                                For x = n + 2 To c + 1
                                    r.Cells(x, 1).Offset(0, 2).Value = r.Cells(x - 1, 1).Offset(0, 2).Value - r.Cells(x, 1).Offset(-1, -4).Value - r.Cells(x, 1).Offset(-1, -2).Value 'pour les ordonnées
                                    r.Cells(x, 1).Offset(0, 3).Value = r.Cells(x - 1, 1).Offset(0, 1).Value 'pour longueur donc les abscisses
                                Next x
                            End If
                        Next n
                    End If
                Next c
            End If
        Next i
    End If
    Macroenreg
hors:
End Sub
Private Sub Macroenreg()
    ActiveWindow.SmallScroll Down:=-12
    Range("X13:Y55").Select
    Range("Y13").Activate
    ActiveSheet.Shapes.AddChart2(240, xlXYScatterLines).Select
    ActiveChart.SetSourceData Source:=Range("'Feuille de calculs'!$X$13:$Y$65")
    Application.CutCopyMode = False
    ActiveChart.FullSeriesCollection(1).XValues = "='Feuille de calculs'!$X$13:$Y$65"
    ActiveChart.FullSeriesCollection(1).Values = "='Feuille de calculs'!$X$13:$X$65"
    ActiveChart.FullSeriesCollection(1).XValues = "='Feuille de calculs'!$Y$13:$Y$65"
    With ActiveChart
        .HasTitle = True
        .ChartTitle.Characters.Text = "Graphique des pertes de charge du réseau aéraulique"
        With .Axes(xlValue, xlPrimary)
            .HasTitle = True
            .AxisTitle.Characters.Text = "Pression [Pa]"
        End With
        With .Axes(xlCategory, xlPrimary)
            .HasTitle = True
            .AxisTitle.Characters.Text = "Position [m]"
        End With
    End With
        'ActiveSheet.ChartObjects.Delete
End Sub
Function Find_Next(Rng As Range, texte As String, Tbl()) As Boolean
    Dim Nbre As Integer, Lig As Long, Cptr As Long
    Nbre = Application.CountIf(Rng, texte)
    If Nbre > 0 Then
        ReDim Tbl(Nbre - 1)
        Lig = 1
        For Cptr = 0 To Nbre - 1
            Lig = Rng.Find(texte, Cells(Lig, Rng.Column), xlValues).Row
            Tbl(Cptr) = Cells(Lig, Rng.Column).Address
        Next
    Else
        GoTo Absent
    End If
    Find_Next = True
    Exit Function
Absent:
    Find_Next = False
End Function

 

[Staple1600]

Bonsoir le fil, le forum

Une réponse avec un peu de décalage
(mais bon fallait bien digérer l'abus de galettes des rois )
Un petit exemple (NB: C'est donc juste une macro illustrative)
(à tester sur une feuille vierge)
Voir les commentaires dans le code pour voir où se situe la suppression du graphique.

Sub RegenereGraphique()
Randomize 'juste pour test
Application.ScreenUpdating = False
[A1:D1] = Array("Item1", "Item2", "Item3", "Item4")
[A2:D20].Formula = "=ROW()*COLUMN()+ROW()*RAND()"
On Error Resume Next
'suppression du graphique (et plus si d'autres objets présents)
ActiveSheet.ChartObjects.Delete
On Error GoTo 0
With ActiveSheet.ChartObjects.Add _
        (Left:=250, Width:=400, Top:=25, Height:=300)
    With .Chart
        .ChartType = xlXYScatterLines
        .SetSourceData Source:=ActiveSheet.Range("A1:D20") ' à adapter
        .Parent.Name = "Graphique Test_" & Int((Rnd * 100) + 1) 'juste pour vérifier que le graphique change
    End With
End With
End Sub

 

[othmane_007_007]

Bonjour,

Je vous remercie ! ça fonctionne parfaitement !
Est ce possible d'ajouter une sorte de croix de fermeture au graphique par hasard ?

Bien à vous

 

[Staple1600]

Bonsoir le fil, le forum

@othmane_007_007
Qu'appelles-tu une croix de fermeture au graphique?
Tu veux le masquer (ou le supprimer) quand on clique dessus?

 

[othmane_007_007]

bonjour,

Comme sur une fenetre Web, la croix au coin supérieur droit, permettant de supprimer la page

Oui un truc permettant de supprimer le graphique lors qu'on le désire

Merci