Обновление или перезапись в существующей диаграмме VBA - PullRequest
Новая
       7

Обновление или перезапись в существующей диаграмме VBA

0 голосов
/ 14 апреля 2020

Привет всем, я создаю код vba, который представляет диаграмму, мой вопрос: как я могу обновить или перезаписать коллекцию рядов или значения в моем графике, созданные, потому что каждый раз, когда я запускаю свою подпрограмму, она создает n графиков, если я запускаю подпрограмму n раз, или какую идею вы порекомендуете мне, чтобы получить свою цель?, я ценю вашу помощь, вот код: 

Sub Grafica()
'*** Creación de gráficas
Dim MyChartName As String
Dim CreateChart As Boolean
Dim Graph As ChartObject
Dim doc As Workbook

Set doc = ThisWorkbook
found = False 'buscador de hojas repetidas

With doc 'examina si en el libro hay hojas repetidas'
    For Each ws In doc.Worksheets 'examina en cada hoja de las que hay en el excel local
        If (LCase(ws.Name) = LCase("Series_Graph")) Then
            found = True
            Set ws = ws 'al hallar condición se fija la hoja existente para colocar valor, (creo que con esto sirve para actualizar)
            Exit For
        End If
    Next

    If (Not found) Then 'en caso la hoja no exista crea una nueva con el nombreasignado por defecto: DATA_nombrehojaexaminada
        Set ws = .Sheets.Add(After:=.Sheets(.Sheets.count))
        ws.Name = "Series_Graph"
    End If

End With


Set Sheetg = doc.Sheets("Series_Graph") 'Hoja de gráfico
MyChartName = "Gráfica 1"
CreateChart = True

If Sheetg.ChartObjects.count > 0 Then
  For Each Graph In Sheetg.ChartObjects
    If Graph.Name = MyChartName Then
      CreateChart = False
      Set Graph = Sheetg.ChartObjects(MyChartName)
    End If
  Next
End If

If CreateChart = True Then
    Set Graph = Sheetg.ChartObjects.Add(Top:=15, Left:=0, Width:=510.236, Height:=1020.47)
    Graph.Name = MyChartName
End If
With Graph.Chart
    '.SetSourceData rng 'Since we already set the range of cells to be used for chart we have use RNG object here
    .ChartType = xlXYScatterLinesNoMarkers
    .HasTitle = True
    .ChartTitle.Text = "IN-GAP-04" & vbCr & _
                            "Eje " & "A" & vbCr & _
                            "Azimut: " & "268.16" & "°"
    .ChartTitle.Font.Name = "Arial"
    .ChartTitle.Font.Color = RGB(0, 0, 0)
    .ChartTitle.Font.Bold = True
    .ChartTitle.Font.Size = 16
    .ChartTitle.HorizontalAlignment = xlHAlignCenterAcrossSelection
    .Axes(xlValue).MinimumScale = Round(((RanArray1(1)(1)) / 2), 0) * 2
    .Axes(xlValue).MaximumScale = Round((RanArray1(1)(0) / 2), 0) * 2
    '.SetElement msoElementPrimaryValueGridLinesNone
    .Axes(xlValue).TickLabels.Font.Name = "Arial"
    '.Axes(xlXValue).TickLabels.Font.Name = "Arial"
    .SeriesCollection.NewSeries
    .SeriesCollection(1).Name = "Rango de precisión"
    .SeriesCollection(1).XValues = RanArray1(0)
    .SeriesCollection(1).Values = RanArray1(1)
    .SeriesCollection(1).Select
    With Selection.Format.Line
        .Visible = msoTrue
        .DashStyle = 3 '3 o msoLineRoundDot cualquiera de las 2 expresiones es valida
        .ForeColor.RGB = RGB(255, 0, 0) 'rojo
        .Weight = 2.25
    End With

End With



Debug.Print Graph.Name
'Debug.Print Round((RanArray1(1)(0) / 2), 0) * 2
'Debug.Print Join(RanArray1(1), ",")

End Sub

1 Ответ

0 голосов
/ 15 апреля 2020

Предполагая, что у вас есть только один график, вы должны удалить все текущие существующие графики, а затем добавить один график, который будет самым последним (обновленный). Добавьте следующие строки кода перед началом форматирования диаграммы (рисунок ниже) 

For i = Graph.Chart.SeriesCollection.Count To 1 Step -1
    Graph.Chart.SeriesCollection(i).Delete
Next i

enter image description here

Если вы посмотрите на текущий код, он добавляет новая серия ".SeriesCollection.NewSeries", но вы обновляете только первую серию (индекс 1). Поэтому вы можете удалить все серии заранее, и при добавлении новой серии по умолчанию это будет индекс 1, и все должно работать. Или вы можете сделать оператор if, чтобы проверить, существует ли серия, если нет, то нет необходимости создавать новую серию.

...