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

时间：2015-10-30 18:03:35

标签： excel vba excel-vba charts formatting

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

1 个答案:

答案 0 :(得分：6)

之前我已经解决了这个问题。我有由宏创建的图表，但它只适用于我创建它们的日期。因此，在每个Workbook打开后运行刷新宏。我之前使用过source，发现它删除了所有内容。然后转移到系列。我会在这里粘贴我的作品并尝试解释。为了快速导航，那里的代码的第二部分称为sub aktualizacegrafu（）可能会帮助你，如果你迷路了在代码的上半部分找到一个以sub generacegrafu开头的引用（）

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 =列表1 R12C1：R13C16 activechart.seriescollection（1）。名称= R1C1的List1：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。它让我好奇，因为我最近解决了同样的问题 如果您需要任何进一步的解释，请对此进行评论，我将尝试解释

相关问题
最新问题