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

othmane_007_007

XLDnaute Nouveau
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

Code:
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
 

Pièces jointes

  • test graph.xlsm
    27.6 KB · Affichages: 21

Staple1600

XLDnaute Barbatruc
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.
VB:
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