Elimina serie di grafici, ma mantenere la loro formattazione

Question

Questo è il codice che uso per creare dinamicamente grafici in 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 

Come posso mantenere la formattazione di serie che viene applicato nella parte If bIssetSourceChart durante l'eliminazione di quelli della serie dati?

Answer 1

Ho già risolto questo problema. Ho dei grafici creati con la macro ma si applica solo alla data in cui li ho creati. Quindi è stata creata una macro di aggiornamento che viene eseguita dopo l'apertura di ogni cartella di lavoro. Ho usato la fonte prima e ho scoperto che cancella tutto. quindi passò solo alle serie. Incollerò qui il mio lavoro e cercherò di spiegare. Per la navigazione veloce nella seconda parte del codice laggiù chiamato sub aktualizacegrafu() potrebbe aiutare a se si perde trovare un riferimento nella parte superiore del codice che inizia con 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 

il risultato che ho trovato è che non riesce a tenere formattazione completamente quando si chiude grafico perché fonte di grafico non funziona molto bene e quando si elimina un formato sarà perso posterò la mia attualizzazione del grafico come pure

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 

qui entra stringa che contiene l'indirizzo della cella desiderata. Lo inserisco sempre come stringa perché è più facile vederlo con il debug. stampare ciò che viene immesso

risultato assomiglia a questo elenco significa Foglio in Repubblica 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 

così risultato di questo è quando in realtà hanno un grafico già, ma desidera apportare lievi modifiche alla zona si applica a allora mantiene la speranza formattazione questo ha aiutato un po ', se non mi dispiace se ha mantenuto la Revard. Mi ha solo incuriosito perché stavo risolvendo lo stesso problema di recente se hai bisogno di ulteriori spiegazioni commentarlo e proverò a spiegare