Create a “Chart Index”, Excel worksheet

Option Explicit

Public Sub CreateChartIndex()
' Macro to create a "Chart Index" worksheet that auto generates a listing of all
' the workbook's Charts, creates a preview icon and hyperlinks to the original

' Set these inputs here (or set them as procedural inputs)
Const SHEET_NAME_CHART_INDEX As String = "Chart Index"
Const RANGE_ROW_CHART_INDEX As String = 7
Const CHART_PREVIEW As Boolean = True

Dim count As Integer
Dim sht As Worksheet
Dim shtIndex As Worksheet
Dim strSheetName As String

Dim cht As Chart
Dim chtObj As ChartObject
Dim shtChartTitle As String
Dim srs As Series
Dim strSeriesNames As String
Dim shp1 As ShapeRange
Dim shp2 As ShapeRange
Dim pic As Picture

    Application.ScreenUpdating = False ' Speed optimisation
    Application.EnableCancelKey = xlDisabled ' Excel Bug Fix for preventing random "Code execution has been interrupted" errors
   
    ' Create "Chart Index" sheet
    If WorksheetExists(SHEET_NAME_CHART_INDEX) = False Then
        Sheets.Add Before:=Sheets(1)
        Set shtIndex = Sheets(1)
        shtIndex.Name = SHEET_NAME_CHART_INDEX
    Else
        Set shtIndex = Sheets(SHEET_NAME_CHART_INDEX)
    End If
   
    ' Delete All
    Cells.Select
    Selection.Delete
    For Each pic In ActiveSheet.Pictures
        pic.Delete
    Next pic
   
    ' Add macro button (to run this macro)
    shtIndex.Buttons.Add(20, 20, 130, 30).Select
    shtIndex.Buttons(1).Name = "CreateChartIndex"
    Selection.OnAction = "CreateChartIndex"
    Selection.Characters.Text = "Create Chart Index"
    Selection.Characters(Start:=1, Length:=18).Font.Size = 14
   
    count = RANGE_ROW_CHART_INDEX
   
    shtIndex.Select
    shtIndex.Range("A1").Select
   
    ' Clear any previous Chart Index and create new Headers
    With shtIndex
        .Range("A" & count).Value = "Preview"
        .Range("B" & count).Value = "Sheet (and graph link)"
        .Range("C" & count).Value = "Chart Title"
        .Range("D" & count).Value = "Chart Series"
       
        .Range("A" & count).Font.Bold = True
        .Range("B" & count).Font.Bold = True
        .Range("C" & count).Font.Bold = True
        .Range("D" & count).Font.Bold = True
    End With
     
    ' Cycle Sheets
    For Each sht In ActiveWorkbook.Sheets
        strSheetName = sht.Name
       
        If strSheetName <> SHEET_NAME_CHART_INDEX Then
            ' Cycle Charts
            For Each chtObj In sht.ChartObjects
                count = count + 1
                Set cht = chtObj.Chart
               
                If cht.HasTitle Then
                    shtChartTitle = cht.ChartTitle.Text
                Else
                    shtChartTitle = "NA"
                End If
               
                ' Find Top Left cell under chart (to act as a hyperlink ref)
                Dim rge As Range
                Set rge = Range(Cells(chtObj.TopLeftCell.Row, chtObj.TopLeftCell.Column), _
                                Cells(chtObj.BottomRightCell.Row, chtObj.BottomRightCell.Column))

                ' Cycle Chart Series
                ' Get List of Series for a given chart
                strSeriesNames = ""
                For Each srs In cht.SeriesCollection
                    strSeriesNames = strSeriesNames & srs.Name & ", "
                Next
                strSeriesNames = Left(strSeriesNames, Len(strSeriesNames) - 2)
               
                ' Print information for a particular graph to "Chart Index"
                shtIndex.Hyperlinks.Add Anchor:=shtIndex.Range("B" & count), Address:="", SubAddress:="'" & _
                                                strSheetName & "'!" & rge.Address, TextToDisplay:=strSheetName
                shtIndex.Range("C" & count).Value = shtChartTitle
                shtIndex.Range("D" & count).Value = strSeriesNames
               
                ' Create a chart preview
                If CHART_PREVIEW Then
                    '   Copy chart and paste as a GIF
                    cht.ChartArea.Copy
                    Range("A1").Select
                    shtIndex.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False _
                        , DisplayAsIcon:=False
                    '   Resize chart (smaller)
                    Set shp1 = Selection.ShapeRange
                    shp1.Height = shtIndex.Rows(count).Height
                    shp1.LockAspectRatio = msoFalse
                    shp1.Width = shtIndex.Columns(1).Width
                    '   Copy paste GIF (to make underlying object size small (memory saving))
                    Selection.Copy
                    Range("A1").Select ' object deselection loses reference to original larger chart
                    shtIndex.PasteSpecial Format:="Picture (GIF)", Link:=False _
                        , DisplayAsIcon:=False
                       
                    Set shp2 = Selection.ShapeRange
                    shp1.Delete
                   
                    ' Set location
                    shp2.Left = shtIndex.Range("A" & count).Left '- shp2.Width
                    shp2.Top = shtIndex.Range("A" & count).Top
                    Range("A1").Select
                   
               
                   
                End If
            Next
        End If
    Next sht
   
    ' Sheet Formating
    Columns("B:C").EntireColumn.AutoFit
    ActiveSheet.Shapes("CreateChartIndex").Width = 140
   
    Application.ScreenUpdating = True
    Application.EnableCancelKey = xlInterrupt ' Excel Bug Fix for preventing random "Code execution has been interrupted" errors
End Sub

Private Function WorksheetExists(shtName As String) As Boolean
' Check if a worksheet already exists (not an in-built, excel function)
Dim sht As Worksheet
Dim rtn As Boolean

    rtn = False
   
    shtName = UCase(shtName)
    For Each sht In ThisWorkbook.Sheets
        If UCase(sht.Name) = shtName Then
            rtn = True
            Exit For
        End If
    Next
   
    WorksheetExists = rtn
   
End Function