这是我用来在Virtual 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 部分中应用的系列格式？

最佳答案

我以前解决过这个问题。我有由宏创建的图表，但它仅适用于我制作它们的日期。因此，制作了一个在每个工作簿打开后运行的刷新宏。我之前使用过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 更容易看到正在输入的内容

结果看起来像这个列表在捷克语中表示工作表 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

所以结果是当您实际上已经有一个图表但想要对其适用的区域进行轻微更改时，它会保持格式 希望这能有所帮助，如果没有的话我很抱歉，如果它确实保留了revard。这让我很好奇，因为我最近正在解决同样的问题 如果您需要任何进一步的解释，请对此发表评论，我会尽力解释

关于vba - 删除图表系列但保留其格式，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/33442261/