删除图表系列但保留其格式设置

Question

删除图表系列但保留其格式设置

6

这是我用来动态创建图表的代码，使用的是 Visual Basic：

Dim Chart As Object
Set Chart = Charts.Add
With Chart
    If bIssetSourceChart Then
        CopySourceChart
        .Paste Type:=xlFormats
    End If
    For Each s In .SeriesCollection
        s.Delete
    Next s
    .ChartType = xlColumnClustered
    .Location Where:=xlLocationAsNewSheet, Name:=chartTitle
    Sheets(chartTitle).Move After:=Sheets(Sheets.count)
    With .SeriesCollection.NewSeries
        If Val(Application.Version) >= 12 Then
            .values = values
            .XValues = columns
            .Name = chartTitle
        Else
            .Select
            Names.Add "_", columns
            ExecuteExcel4Macro "series.columns(!_)"
            Names.Add "_", values
            ExecuteExcel4Macro "series.values(,!_)"
            Names("_").Delete
        End If
    End With
End With

#The CopySourceChart Sub:
Sub CopySourceChart()
    If Not CheckSheet("Source chart") Then
        Exit Sub
    ElseIf TypeName(Sheets("Grafiek")) = "Chart" Then
        Sheets("Grafiek").ChartArea.Copy
    Else
        Dim Chart As ChartObject

        For Each Chart In Sheets("Grafiek").ChartObjects
            Chart.Chart.ChartArea.Copy
            Exit Sub
        Next Chart
    End If
End Sub

在删除这些系列的数据时，我该如何保留应用于If bIssetSourceChart部分的格式？

- Jonan

似乎过程的一个关键部分丢失了，需要补充一些信息。现在的代码方式，CopySource_Chart 过程将永远不会被执行。请问您能否发布您的工作簿，这样我们就可以更好地了解您想要保存的设置以及您打算如何保留它们？您计划如何使用它们呢？ - EEM

我有一个问题，为什么你要在图表中删除系列，然后用 .SeriesCollection.NewSeries创建一个新的系列？有没有一种选择是只删除除第一个系列外的所有系列，然后更改它的数据，以保持旧的格式化？ - A.S.H

如果你接受我提出的选项，它可以被调整以保留所需的序列中的尽可能多的序列，而不仅仅是一个序列。我们使用我们想要的系列数量（例如，在您的代码中仅为一个，但您可能需要更多），我们保留它们以保持其格式，并仅修改它们的值，然后删除任何剩余的系列。请告诉我这个解决方法是否适用于您，因为保存已删除系列的格式似乎非常繁琐：系列的格式对象具有许多属性和“深度引用”，它不能轻松克隆以进行保存... - A.S.H

1个回答

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- Lance · Accepted Answer

我之前曾解决过这个问题。我有一些图表是通过宏创建的，但只适用于我制作它们的日期。因此，我创建了一个刷新宏，在每次工作簿打开后运行。我先使用source，发现它会删除所有内容，然后转而只处理系列。我将我的工作粘贴在这里，并尝试解释。为了快速导航，下面代码的第二部分名为sub aktualizacegrafu()可能会帮助您，如果您在上面的代码中迷失，请查找参考。

Sub generacegrafu()
ThisWorkbook.Sheets("List1").CommandButton6.BackColor = &H0&
ThisWorkbook.Sheets("List1").CommandButton6.ForeColor = &HFFFFFF
Dim najdiposlradek As Object
Dim graf As Object
Dim vkladacistring As String
Dim vykreslenysloupec As Integer
Dim hledejsloupec As Object
Dim hledejsloupec2 As Object
Dim kvantifikator As Integer
Dim grafx As ChartObject
Dim shoda As Boolean
Dim jmenografu As String
Dim rngOrigSelection As Range


Cells(1, 1).Select
If refreshcharts = True Then
    Set hledejsloupec = Range("11:11").Find(What:=prvnislovo, LookIn:=xlValues) 
'dynamicaly generated, prvnislovo is for first word in graph and the macro looks for match in row 11 if it doesnt find any then
Else
'then it looks for match in option box
    Set hledejsloupec = Range("11:11").Find(What:=ThisWorkbook.Sheets("List1").ComboBox1.Value, LookIn:=xlValues) 
End If
If hledejsloupec Is Nothing Then
    MsgBox "Zadaný sloupec v první nabídce nebyl nalezen."
Else
    If refreshcharts = True Then
        Set hledejsloupec2 = Range("11:11").Find(What:=druheslovo, LookIn:=xlValues)
    Else
        Set hledejsloupec2 = Range("11:11").Find(What:=ThisWorkbook.Sheets("List1").ComboBox2.Value, LookIn:=xlValues)
    End If
    If hledejsloupec2 Is Nothing Then
        MsgBox "Zadaný sloupec v druhé nabídce nebyl nalezen."
    Else
        jmenografu = Cells(11, hledejsloupec.Column).Value & "_" & Cells(11, hledejsloupec2.Column).Value
        Set najdiposlradek = Range("A:A").Find(What:=Date, LookIn:=xlValues)

        Application.ScreenUpdating = False
        Set rngOrigSelection = Selection
       'This one selects series for new graph to be created
        Cells(1048576, 16384).Select
        Set graf = ThisWorkbook.Sheets("List1").Shapes.AddChart
        rngOrigSelection.Parent.Parent.Activate
        rngOrigSelection.Parent.Select
        rngOrigSelection.Select 'trouble with annoing excel feature to unselect graphs

        Application.ScreenUpdating = True

        graf.Select
        kvantifikator = 1
        Do
            shoda = False
            For Each grafx In ThisWorkbook.Sheets("List1").ChartObjects
                If grafx.Name = jmenografu Then
                    shoda = True
                    jmenografu = jmenografu & "(" & kvantifikator & ")"
                    kvantifikator = kvantifikator + 1
                End If
            Next grafx
    'this checks if graph has younger brother in sheet
'but no we get to the part that matter do not bother playing with source of the graph because I have found it is quite hard to make it work properly
        Loop Until shoda = False
'here it starts
        ActiveChart.Parent.Name = jmenografu
        ActiveChart.SeriesCollection.NewSeries 'add only series!
        vkladacistring = "=List1!R12C" & hledejsloupec.Column & ":R" & najdiposlradek.Row & "C" & hledejsloupec.Column 'insert this into series
        ActiveChart.SeriesCollection(1).Values = vkladacistring
        vkladacistring = "=List1!R11C" & hledejsloupec.Column
        ActiveChart.SeriesCollection(1).Name = vkladacistring
        vkladacistring = "=List1!R12C" & hledejsloupec2.Column & ":R" & najdiposlradek.Row & "C" & hledejsloupec2.Column
        ActiveChart.SeriesCollection(1).XValues = vkladacistring
'here it ends and onward comes formating
        ActiveChart.Legend.Delete
        ActiveChart.ChartType = xlConeColClustered
        ActiveChart.ClearToMatchStyle
        ActiveChart.ChartStyle = 41
        ActiveChart.ClearToMatchStyle
        ActiveSheet.Shapes(jmenografu).Chart.ChartArea.Format.ThreeD.RotationY = 90
        ActiveSheet.Shapes(jmenografu).Chart.ChartArea.Format.ThreeD.RotationX = 0
        ActiveChart.Axes(xlValue).MajorUnit = 8.33333333333333E-02
        ActiveChart.Axes(xlValue).MinimumScale = 0.25
        ActiveChart.Walls.Format.Fill.Visible = msoFalse
        ActiveChart.Axes(xlCategory).MajorUnitScale = xlMonths
        ActiveChart.Axes(xlCategory).MajorUnit = 1
        ActiveChart.Axes(xlCategory).BaseUnit = xlDays
    End If
End If
Call aktualizacelistboxu
ThisWorkbook.Sheets("List1").CommandButton6.BackColor = &H8000000D
ThisWorkbook.Sheets("List1").CommandButton6.ForeColor = &H0&
End Sub

我发现的结果是，在关闭图表时，由于图表的源代码无法正常工作，因此您无法完全保留格式。当您删除它时，某些格式将丢失。

我也会发布我的图表更新。

Sub aktualizacegrafu()
Dim grafx As ChartObject
Dim hledejsloupec As Object
Dim hledejsloupec2 As Object
Dim vkladacistring As String
Dim najdiposlradek As Object

For Each grafx In ThisWorkbook.Sheets("List1").ChartObjects
    prvnislovo = Left(grafx.Name, InStr(1, grafx.Name, "_") - 1)
    druheslovo = Right(grafx.Name, Len(grafx.Name) - InStr(1, grafx.Name, "_")) 
'now it checks the names of charts .. the data loads from respective columns that are named the same way so I ussualy choose what statistic I want by choosing the columns needed
'for example I want to reflect my arrivals to work according to the hours I worked or to the date so I set 1st option to arrival and 2nd to date
grafx.Activate
Set najdiposlradek = Range("A:A").Find(What:=Date, LookIn:=xlValues)
Set hledejsloupec = Range("11:11").Find(What:=prvnislovo, LookIn:=xlValues)
If hledejsloupec Is Nothing Then
    MsgBox "Hodnota v grafu již není mezi sloupci v tabulce. Aktualizace grafu " & grafx.Name & " bude ukončena."
Else
    Set hledejsloupec2 = Range("11:11").Find(What:=druheslovo, LookIn:=xlValues)
    If hledejsloupec2 Is Nothing Then
        MsgBox "Hodnota v grafu již není mezi sloupci v tabulce. Aktualizace grafu " & grafx.Name & " bude ukončena."
    Else

这里输入包含所需单元格地址的字符串，我总是将其输入为字符串，因为使用debug.print更容易查看正在输入的内容。

结果看起来像这样：List在捷克语中表示Sheet activechart.seriescollection(1).values=List1!R12C1:R13C16 activechart.seriescollection(1).name=List1!R1C1:R1C15

        vkladacistring = "=List1!R12C" & hledejsloupec.Column & ":R" & najdiposlradek.Row & "C" & hledejsloupec.Column
        ActiveChart.SeriesCollection(1).Values = vkladacistring
        vkladacistring = "=List1!R11C" & hledejsloupec.Column
        ActiveChart.SeriesCollection(1).Name = vkladacistring
        vkladacistring = "=List1!R12C" & hledejsloupec2.Column & ":R" & najdiposlradek.Row & "C" & hledejsloupec2.Column
        ActiveChart.SeriesCollection(1).XValues = vkladacistring
    End If
End If
Next grafx
Call aktualizacelistboxu
End Sub

这个结果是当你已经有一个图表，但想对它应用的区域进行轻微更改时，它会保留格式。希望这有所帮助，如果没有的话很抱歉，如果有的话请保留奖励。这让我感到好奇，因为最近我也在解决同样的问题。如果需要进一步解释，请在评论中提出，我会尝试解释。