VBA Macro to copy all charts in worksheet to separate chart sheets

[gmcgough600]

Hi,

I'd like to copy all charts in a worksheet to separate chart sheets, does anyone know how to do this in a Macro?

Thanks

 

[gmcgough600]

More info on original question:

I have the code below which copies all the charts in chart sheets to Word, but I want it to copy all charts in the workbook. So I can achieve this with either some code to copy all charts in the worksheet to chart sheets or code which skips this step and just copies all charts to Word.

Sub ChartsToWord()


' Requirements
' 1. Get each chart in the active workbook
'   1.1 This is easy using: ActiveWorkbook.charts
' 2. Create a new document
'   2.2 This is easy using: CreateObject("Word.Application).Documents.Add
' 3. Put chart on each page of the nex document


Dim objWord As Object
Dim objDoc As Object
Dim iCht, number_of_columns As Integer
Dim Msg As String
Dim cm_to_inch As Double
cm_to_inch = 0.393701


    '====================
    'Allow for an observations box or not
    number_of_columns = 1
    selection_event = MsgBox("Would you like to include a box for Observations?", vbYesNo, " Contact Server?")
    Select Case selection_event
    Case 6 ' Yes
        number_of_columns = 2
    End Select
    '====================


Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add


' Viwe the word document in development
objWord.Visible = True
' Required orientation of landscape
With objDoc
    .PageSetup.Orientation = 1
End With


'====================
' Require every chart on a new page
For Each oChart In ActiveWorkbook.Charts


    '====================
    ' Copy the chart
    ' copy chart as a picture
    oChart.CopyPicture _
        Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
    '====================
    
    '====================
    'Select the last paragraph, make it the current range to add a new table
    Set aRange = objDoc.Paragraphs.Last.Range
    Set objTbl = objDoc.tables.Add(Range:=aRange, NumRows:=1, NumColumns:=number_of_columns)
    '====================
    
    '====================
    ' Set default properties of table
    With objTbl
        .AllowAutoFit = True
    End With
    '====================


    '====================
    ' Allow for formatting of the observation box
    If number_of_columns > 1 Then
        ' Select the observations section and give it a border
        Set observations = objTbl.Cell(1, 2)
        ' Attempt to set the borders of the table
        ' This is not working, I currently don't understand why
        observations.Borders.Enable = True
        For Each b In observations.Borders
            b.Color = RGB(0, 70, 135)
        Next b
    End If
    '====================
    
    
    '====================
    ' Select the paste target adn paste the chart
    ' Select the first cell of the table
    Set paste_target = objTbl.Cell(1, 1).Range
    ' Paste the copied chart
    paste_target.PasteSpecial Placement:=wdInLine
    ' Select the copied chart and resize
    objDoc.InlineShapes(objDoc.InlineShapes.Count).Height = 13 * cm_to_inch * 72
    ' Add caption
    objDoc.Paragraphs.Last.Range.InsertCaption Label:="Figure", _
    Title:=": Replace with content", Position:=wdCaptionPositionBelow
    ' Add a page break
    objDoc.Paragraphs.Last.Range.InsertBreak
    '====================
    
Next oChart
'====================


Set objDoc = Nothing
Set objWord = Nothing
Set objTbl = Nothing
Set paste_target = Nothing


End Sub

Thanks!