Dynamic Excel Chart duplication?

[mischifous]

Hi everyone,

There must be a tool out there that can help me accomplish this:\


I have a very large set of data that spans over a couple of years. Each day is a row, and there are multiple columns of data. Lets say column A is dates, and then columns B through Z are data.
Lets say I create simple line chart plotting the data in column B over time (column A).
Now lets say i want to be able to seamlessly recreate this chart 25x more times for the data in column C - Z, but over time (ie COLUMN A which is the day data). I want these copied charts to have the same formatting as the original chart.


The reality of the situation is that there are far more than just 27 columns and creating each chart one at a time, and re-referencing the data is incredibly time consuming. This is especially the case when I must change the formatting or data range of my charts, and then must go back and manually do this for all the remaining ones.

I wish I could offer whoever gives me a solution to this money, but I know it's against the forum rules. I know there was a plugin that allowed me to copy paste charts and offset the reference range data really seamlessly, but i have spent months looking for it and can no longer find out what it is called. So any other solutions much appreciated.

Thank you guys for your service on these forums, really appreciate it.

 

[MoshiM]

Hi everyone,

There must be a tool out there that can help me accomplish this:\

Thank you guys for your service on these forums, really appreciate it.

I wrote something for like this for my own project a while ago the caveat being that it doesn't copy the charts but instead updates the values. It was originally built to interface with a combobox to change the referenced worksheet, but I have stripped that functionality from it as you haven't mentioned anything like that. It can probably be further edited to more precisely suit your purposes but it should do the trick.

Please note the red text and that the macro will only work if your data is in a table starting at cell A1. I'm not sure of all the chart types it will work with but it will work properly for every series in a line chart.

If copying the chart is absolutely necessary then reply back saying so and I can try and figure something out.

Private Sub Update_Charts() 'changing Chart Data


Dim Worksheet_Name as string,TT As Long, AR As Range, HAT() As Variant, Date_Range As Range, Item As ChartObject, SS As Series, _
Hold_Errors As New Collection, ERF As String ', DD As Double


'DD = Timer


On Error GoTo No_Table

Worksheet_Name= "[COLOR=#b22222]Put Worksheet Name here[/COLOR]"


With ThisWorkbook.Worksheets(Worksheet_Name).Range("A1").ListObject


    Set AR = .DataBodyRange 'databodyrange of table stored in a variable


    HAT = .HeaderRowRange.Value2 'store headers in an array


End With


Set Date_Range = AR.Columns(1) 'First Column of table holds dates
    
Application.ScreenUpdating = False


On Error GoTo Chart_Data_NFound


For Each Item In ActiveSheet.ChartObjects 'for each chart on the activesheet


    For Each SS In Item.Chart.FullSeriesCollection 'for each series on that chart
        With SS
            'split the series formula with a comma then split the second element(base 0) with a ":". The 1st element (base 0) of the new string is the target column
            'use .column to find the column index
            TT = Range(Split(Split(.Formula, ",")(2), ":")(1)).Column 'find the column reference number within the table
                .XValues = Date_Range 'xvalues come from column 1 of the table
                .Values = AR.Columns(TT) 'update series values
                .Name = HAT(1, TT) 'rename series with the header from that column
        End With
Skip_Series:
    Next SS


Next Item

With Hold_Errors 'show message box if errors were encountered


    If .count > 0 Then
        
        For TT = 1 To .count
        
            ERF = ERF & vbNewLine & Hold_Errors(TT)
            
        Next TT
        
        MsgBox ERF
    
    End If


End With


Exit Sub


No_Table:


    MsgBox "Table was not found in cell A1 on sheet "  & Worksheet_Name
    Exit Sub


Chart_Data_NFound:


    Hold_Errors.Add "No data found for  & SS.Name & " on chart " & _
    Item.Chart.ChartTitle.Text
    
    Err.Clear
    
    GoTo Skip_Series
    
End Sub

 

[MoshiM]

This one will copy charts and update values.

I've made the assumption that all the charts will be on the same sheet as the data source and each chart will have only 1 series. One problem you'll run into is that the charts will be layered ontop of each other, however they will be named based on the header for the series' column so you can use the selection pane to select/move specific charts.

Read the red text

Sub Copy_Chart()


Dim Total_Charts As Long, x As Long, Original_Chart As ChartObject, Copied_Chart As ChartObject, Data_Table As Range, _
HAT As Variant, Hold_Errors As New Collection, WS As Worksheet, ERF As String

application.screenupdating=false


Set WS = ThisWorkbook.Worksheets("[COLOR=#ff0000]Name of Worksheet with data[/COLOR]")'replace everything after the = sign with ActiveSheet if you will always be running this macro while on the data source sheet 

if ws.chartobjects.count=0 then
     msgbox "There are no charts on sheet " & ws.name
     exit sub
end if


On Error GoTo No_Table


With WS.Range("A1").ListObject 'Table must start in cell A1


    Set Data_Table = .DataBodyRange 'store values


    HAT = .HeaderRowRange.Value2 'store headers


End With


'With WS.UsedRange[COLOR=#ff0000] 'Uncomment this with block if data isn't in a table.  Remove previous with block[/COLOR]
'
'    Set Data_Table = WS.Range(WS.Cells(2, 1), WS.Cells(.Rows.count, .Columns.count))
'    HAT = .Rows(1).Value2
'
'End With


Total_Charts = Data_Table.Columns.count  'assumes chart was first created with data starting in column B


Set Original_Chart = WS.ChartObjects(WS.ChartObjects.count) 'creates a reference to the most recently created chart


On Error GoTo Chart_Data_NFound


For x = 2 To Total_Charts
    
    If LCase(HAT(1, x)) <> LCase(Original_Chart.Chart.ChartTitle.Text) Then 'original chart must be named with a header to prevent duplicates
    
        Original_Chart.Duplicate
        
        Set Copied_Chart = WS.ChartObjects(WS.ChartObjects.count)
        Copied_Chart.Name = HAT(1, x)
        With Copied_Chart.Chart
            
            With .FullSeriesCollection(1) 'assumes only 1 series on the chart
                .Values = Data_Table.Columns(x)
                .Name = HAT(1, x) 'change the name of the series to match header
            End With
            
                .ChartTitle.Text = HAT(1, x) 'change chart title to header
            
        End With
        
Skip_Series:
    
    End If


Next x


With Hold_Errors 'show message box if errors were encountered


    If .count > 0 Then
        
        For TT = 1 To .count
        
            ERF = ERF & vbNewLine & Hold_Errors(TT)
            
        Next TT
        
        MsgBox ERF
    
    End If


End With

application.screenupdating=true


Exit Sub


No_Table:


    MsgBox "Table was not found in cell A1 on sheet " & WS.Name
    Exit Sub


Chart_Data_NFound:


    Hold_Errors.Add "No data found for series" & Chr(19) & HAT(1, x)
    
    Err.Clear
    
    GoTo Skip_Series


End Sub
Sub Delete_All_Charts_on_Current_Sheet()
Dim c As ChartObject
For Each c In ActiveSheet.ChartObjects
    c.Delete
Next
End Sub

 

[MoshiM]

One more version to deal with the layered issue.

Sub Copy_Chart()


Dim Total_Charts As Long, x As Long, Original_Chart As ChartObject, Copied_Chart As Object, Data_Table As Range, _
HAT As Variant, Hold_Errors As New Collection, WS As Worksheet, ERF As String, y As Long


Set WS = ThisWorkbook.Worksheets("[COLOR=#ff0000]Name of Worksheet with data[/COLOR]") '[COLOR=#0000ff]replace everything after the = sign with ActiveSheet if you will always be running this macro while on the data source sheet[/COLOR]


If WS.ChartObjects.count = 0 Then
     MsgBox "There are no charts on sheet " & WS.Name
     Exit Sub
End If


Application.ScreenUpdating = False


On Error GoTo No_Table 'This error statement is for the below With statement
With WS.Range("A1").ListObject 'Table must start in cell A1


    Set Data_Table = .DataBodyRange 'store values


    HAT = .HeaderRowRange.Value2 'store headers


End With


'With WS.UsedRange '[COLOR=#0000ff]Uncomment this With block if data isn't in a table then remove the previous With block.[/COLOR]
'
'    Set Data_Table = WS.Range(WS.Cells(2, 1), WS.Cells(.Rows.count, .Columns.count))'assumes headers in row 1 of worksheet
'    HAT = .Rows(1).Value2'Headers
'
'End With


Total_Charts = Data_Table.Columns.count 


Set Original_Chart = WS.ChartObjects(WS.ChartObjects.count) '[COLOR=#0000ff]creates a reference to the most recently created chart
[/COLOR]

On Error GoTo Chart_Data_NFound


y = 1


For x = 2 To Total_Charts 'start at 2 to avoid making a chart of just dates
    
    If LCase(HAT(1, x)) <> LCase(Original_Chart.Chart.ChartTitle.Text) Then '[COLOR=#ff0000]original chart must be named with a header to prevent duplicates[/COLOR]
        
        Set Copied_Chart = Original_Chart.Duplicate
        
        With Copied_Chart
            
            .Name = HAT(1, x)
             
           [COLOR=#0000ff] 'Charts will be placed in a grid 2 charts wide[/COLOR]           
            If y Mod 2 = 1 Then 'if odd numbered chart duplicate then place to right of previous
                
                .Top = WS.ChartObjects(WS.ChartObjects.count - 1).Top
                
                .Left = .Left + .Width
            
            Else 'if even numbered chart duplicate then place below previous row of charts
                
                .Top = Original_Chart.Top + .Height * (y / 2)
                
            End If
            
            y = y + 1
            
            With .Chart
            
                With .FullSeriesCollection(1) '[COLOR=#0000ff]assumes only 1 series on the chart[/COLOR]
                    
                    .Values = Data_Table.Columns(x) 'adjust values
                    .Name = HAT(1, x) 'change the name of the series to match header
                
                End With
            
                .ChartTitle.Text = HAT(1, x) 'change chart title to header
            
            End With
            
        End With
    
    End If
Skip_Series:
Next x


With Hold_Errors 'show message box if errors were encountered


    If .count > 0 Then
        
        For x = 1 To .count
        
            ERF = ERF & vbNewLine & Hold_Errors(x)
            
        Next x
        
        MsgBox ERF
    
    End If


End With


Application.ScreenUpdating = True


Exit Sub


No_Table:


    MsgBox "Table was not found in cell A1 on sheet " & WS.Name
    Application.ScreenUpdating = True
    Exit Sub


Chart_Data_NFound:


    Hold_Errors.Add "No data found for column " & x & " series" & Chr(19) & HAT(1, x)
    
    Err.Clear
    
    GoTo Skip_Series


End Sub


Sub Delete_All_Charts_on_Current_Sheet()


Dim c As ChartObject


Application.ScreenUpdating = False


For Each c In ActiveSheet.ChartObjects
    
    c.Delete


Next


Application.ScreenUpdating = True


End Sub

 

[mischifous]

it's saying, "run-time error '-2147024809 (80070057)': The specified value is out of range.


how does it know how many rows to do?-- it just looks at the first chart? What about formatting of the first chart? -- like custom y axis range etc?
Btw my data begins AZ9, with names of columns going across row 9, dates down Az10:AZ9999, and data from BA10:DQ9999. I changed the field to AZ9 but not sure if that broke it.

 

[MoshiM]

it's saying, "run-time error '-2147024809 (80070057)': The specified value is out of range.


how does it know how many rows to do?-- it just looks at the first chart? What about formatting of the first chart? -- like custom y axis range etc?
Btw my data begins AZ9, with names of columns going across row 9, dates down Az10:AZ9999, and data from BA10:DQ9999. I changed the field to AZ9 but not sure if that broke it.

Where exactly are you getting an error because it works perfectly on my end? Please ensure that you are reading the comments.

It knows how many charts to create based on the number of columns in the specified range. The macro uses the most recently created Chart/the chart at the top of the selection pane on the Activesheet as a template and then swaps out the data for the duplicated chart.

Sub Copy_Chart()


Dim Total_Charts As Long, x As Long, Original_Chart As ChartObject, Copied_Chart As Object, Data_Table As Range, _
Header_Info As Variant, WS As Worksheet, ERF As String, y As Long, Date_Range As Range


Const Grid_Size = 2


Set WS = ActiveSheet ' OR ThisWorkbook.Worksheets("Name of Worksheet with data") 'replace everything after the = sign with ActiveSheet if you will always be running this macro while on the data source sheet


If WS.ChartObjects.count = 0 Then
     MsgBox "There are no charts on sheet " & WS.Name
     Exit Sub
End If


Application.ScreenUpdating = False


With WS

    Set Data_Table = .Range("BA10:DQ9999")

    Header_Info = .Range("BA9:DQ9").Value2 'Headers 

    'Set Date_Range=.range("Az10:AZ9999") 

End With

Total_Charts = Data_Table.Columns.count 'Total number of charts present at the end

Set Original_Chart = WS.ChartObjects(WS.ChartObjects.count) 'creates a reference to the most recently created chart

On Error GoTo Chart_Data_NFound

y = 1

For x = 1 To Total_Charts
    
    If LCase(Header_Info(1, x)) <> LCase(Original_Chart.Chart.ChartTitle.Text) Then 'original chart must be named with a header to prevent duplicates
        
        Set Copied_Chart = Original_Chart.Duplicate
        
        With Copied_Chart
            
            .Name = Header_Info(1, x)
             
            'Charts will be placed in a grid 2 charts wide
            
            If y Mod Grid_Size <> 0 Then 'place to right of previous chart
                
                .Top = WS.ChartObjects(WS.ChartObjects.count - 1).Top
                
                .Left = .Left + .Width
            
            Else 'place below previous row of charts
                
                .Top = Original_Chart.Top + .Height * (y / 2)
                
            End If
            
            y = y + 1
            
            With .Chart
            
                With .FullSeriesCollection(1) 'assumes only 1 series on the chart
                    
                    .Values = Data_Table.Columns(x) 'adjust values
                    .Name = Header_Info(1, x) 'change the name of the series to match header
                    '.XValues = Date_Range
                    
                End With
            
                .ChartTitle.Text = Header_Info(1, x) 'change chart title to header
            
            End With
            
        End With
    
    End If
    
Skip_Series:

Next x

If ERF <> vbNullString Then MsgBox ERF

Application.ScreenUpdating = True

Exit Sub

No_Table:

    MsgBox "Table was not found in cell A1 on sheet " & WS.Name
    Application.ScreenUpdating = True
    Exit Sub

Chart_Data_NFound:

    ERF = ERF & "No data found for column " & x & " series" & Chr(19) & Header_Info(1, x) & vbNewLine
    
    Err.Clear
    
    GoTo Skip_Series

End Sub