56 graphs on one sheet

[Daisyverma]

Hey everyone
I have a spreadsheet with 56 graphs on one sheet. Is there a macro that will cut and paste each chart and place on a separate worksheet?
A bonus would be if the worksheet can reflect the chart title (department/unit name)

 

[ParamRay]

Here's one way to do it.

Make sure you change the name of the sheet on the line indicated in the code.

It's the first macro that should be run.

Public Sub CopyCharts()
  Const strSHEET_WITH_CHARTS = "Sheet1"   '<--- Set name of sheet containing charts
  Dim intCounter As Integer
  Dim wksTarget As Worksheet
  Dim chtObj As ChartObject
  On Error GoTo ErrorHandler
  For Each chtObj In ThisWorkbook.Sheets(strSHEET_WITH_CHARTS).ChartObjects
    Set wksTarget = CreateWorksheet(chtObj.Chart.ChartTitle.Text)
    chtObj.Copy
    wksTarget.Paste
    intCounter = intCounter + 1
  Next chtObj
  ThisWorkbook.Sheets(strSHEET_WITH_CHARTS).Activate
  MsgBox intCounter & " chart(s) were copied.", vbInformation
ExitHandler:
  Set wksTarget = Nothing
  Set chtObj = Nothing
  Exit Sub
ErrorHandler:
  MsgBox Err.Description, vbExclamation
  Resume ExitHandler
End Sub

Private Function CreateWorksheet(ByVal strSheetName As String) As Worksheet
  Dim strNewName As String
  Dim intCounter As Integer
  strNewName = strSheetName
  Do While SheetExists(strNewName)
    intCounter = intCounter + 1
    strNewName = strSheetName & " (" & intCounter & ")"
  Loop
  With ThisWorkbook.Sheets
    Set CreateWorksheet = .Add(, .Item(.Count))
    CreateWorksheet.Name = strNewName
  End With
End Function

Private Function SheetExists(ByVal strSheetName As String) As Boolean
  Dim objSheet As Object
  On Error Resume Next
  Set objSheet = ThisWorkbook.Sheets(strSheetName)
  On Error GoTo 0
  SheetExists = Not (objSheet Is Nothing)
  Set objSheet = Nothing
End Function