Extract Charts from one excel spreadsheet to another, change the font size and reposition correctly using VBA

Question

I thought to make a macro to make chart moving/position a bit easier however my macro currently is quite arduous and slow - i'm sure this is a more efficient way of doing this!

The problem - I have 2 spreadsheets, plots and plotspdf. Plots spreadsheet has, say 10 charts, and the other (plotspdf) is blank. I want the macro to move a select few charts (for arguments sake lets say 1, 3, 5 and 8) to the other spreadsheet using a simple copy paste. Then I want to change the font size to 8 and format (height and width) of each chart to 7cm X 13cm. Finally, I want to reposition the charts so that they fit nicely on the page - for example Chart 1 is moving to cell A1; Chart 3 is moved to cell G35, etc etc.

This is what I currently have... is there a way to make this code a bit neater/more efficient. Thank you in advance.

Sub ArrangeCharts()
    ActiveSheet.ChartObjects("Chart 1").Activate
    ActiveSheet.Shapes.Range(Array("Chart 1", "Chart 2")).Select
    ActiveSheet.Shapes.Range(Array("Chart 1", "Chart 2", "Chart 3")).Select
    ActiveSheet.Shapes.Range(Array("Chart 1", "Chart 2", "Chart 3", "Chart 4")).Select
    Selection.Copy
    Sheets("plotspdf").Select
    Range("A2").Select
    ActiveSheet.Paste
    Selection.ShapeRange.Height = 198.4251968504
    Selection.ShapeRange.Width = 255.1181102362
    Range("E7").Select
    ActiveSheet.ChartObjects("Chart 4").Activate
    ActiveSheet.Shapes.Range(Array("Chart 4", "Chart 5")).Select
    ActiveSheet.Shapes.Range(Array("Chart 4", "Chart 5", "Chart 6")).Select
    Range("E4").Select
    ActiveSheet.ChartObjects("Chart 4").Activate
    ActiveSheet.Shapes("Chart 4").TextFrame2.TextRange.Font.Size = 8
    ActiveSheet.ChartObjects("Chart 5").Activate
    ActiveSheet.Shapes("Chart 5").TextFrame2.TextRange.Font.Size = 8
    ActiveSheet.ChartObjects("Chart 6").Activate
    ActiveSheet.Shapes("Chart 6").TextFrame2.TextRange.Font.Size = 8
    ActiveSheet.ChartObjects("Chart 7").Activate
    ActiveSheet.Shapes("Chart 7").TextFrame2.TextRange.Font.Size = 8
    ActiveSheet.ChartObjects("Chart 4").Activate
    ActiveSheet.ChartObjects("Chart 4").Activate
    ActiveSheet.Shapes("Chart 4").IncrementLeft 62
    ActiveSheet.Shapes("Chart 4").IncrementTop 12
    ActiveSheet.ChartObjects("Chart 5").Activate
    ActiveChart.PlotArea.Select
    ActiveChart.ChartArea.Select
    ActiveSheet.Shapes("Chart 5").IncrementLeft -125
    ActiveSheet.Shapes("Chart 5").IncrementTop 228
    ActiveSheet.ChartObjects("Chart 7").Activate
    ActiveSheet.Shapes("Chart 7").IncrementLeft -269
    ActiveSheet.Shapes("Chart 7").IncrementTop 174
    ActiveSheet.ChartObjects("Chart 7").Activate
    ActiveSheet.Shapes("Chart 7").IncrementLeft -48
    ActiveSheet.Shapes("Chart 7").IncrementTop 16
End Sub

See [this question](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). — BigBen, Feb 27 '20 at 23:59

score 0 · Accepted Answer · answered Mar 02 '20 at 11:35

This code also checks the chart exists before trying to copy it

Option Explicit
Sub arrangecharts()

    Const H_MM = 70 ' 70 mm
    Const W_MM = 130
    Const FACTOR = 2.835
    Const FONT_SIZE = 8

    Dim CHART_NAME As Variant, CHART_CELL As Variant
    CHART_NAME = Array("Chart 11", "Chart 3", "Chart 4", "Chart 7", "Chart 8")
    CHART_CELL = Array("A2", "I2", "A17", "I17", "A32")

    Dim wb As Workbook, wsSource As Worksheet, wsTarget As Worksheet
    Dim chtObj As ChartObject, dictCharts As Object
    Dim msg As String, i As Integer, count As Integer

    Set wb = ActiveWorkbook 'ThisWorkbook
    Set wsSource = wb.Sheets("plots")
    Set wsTarget = wb.Sheets("plotspdf")

    Set dictCharts = CreateObject("Scripting.Dictionary")
    With wsSource
        For Each chtObj In .ChartObjects
            dictCharts.Add chtObj.Name, chtObj.Index
            msg = msg & vbCr & chtObj.Index & vbTab & chtObj.Name
        Next
    End With
    MsgBox msg, vbInformation, "Charts on " & wsSource.Name

    ' check for charts
    msg = ""
    For i = 0 To UBound(CHART_NAME)
        If Not dictCharts.exists(CHART_NAME(i)) Then
            msg = msg & CHART_NAME(i) & vbCr
        End If
    Next

    ' confirm ignore errors
    If Len(msg) > 0 Then
      msg = "Charts not found" & vbCr & msg & "Continue ?"
      If vbNo = MsgBox(msg, vbYesNo, "Charts not found") Then Exit Sub
    End If

    count = 0
    wsTarget.Activate
    With wsTarget

        ' copy
        For i = 0 To UBound(CHART_NAME)
             'Debug.Print CHART_NAME(i)
             If dictCharts.exists(CHART_NAME(i)) Then
                wsSource.ChartObjects(CHART_NAME(i)).Copy
                .Range(CHART_CELL(i)).Select
                ActiveSheet.Paste
                Application.CutCopyMode = False
                count = count + 1
             End If
        Next

        ' format
        For Each chtObj In .ChartObjects
            'Debug.Print i, chtObj.Name   '
            chtObj.HEIGHT = H_MM * FACTOR
            chtObj.width = W_MM * FACTOR
            chtObj.Chart.ChartArea.Font.Size = FONT_SIZE
        Next

    End With
    MsgBox count & " charts copied", vbInformation, "Finished"

End Sub

Extract Charts from one excel spreadsheet to another, change the font size and reposition correctly using VBA

1 Answers1