CODEWITHSUNDEEP
vbaexcelcharts
MBBertolucci
MBBertolucci

Reputation: 1341

VBA: Organizing Chart Objects in worksheet

I have a workbook with several Chart Sheets. I want to create a sheet where all charts can be easily found all at once, so I can rapidly copy and then paste them in powerpoint presentations.

My code can copy, paste and change the size of each chart sheet just fine. The trouble comes when I try to organize them in the sheet.

The thing is that the code pastes them all in a single line. If, for instance, I have a large number of charts, finding a specific one could take too much time.

I would like to organize all charts in something of this sort, disposing a specific number of charts for each row (say, for instance, 2 charts per row).

enter image description here

I tried to use the .left property for charts, but it aligns all charts to the same column (and please notice that this is not my intention).

I have also tried to introduce a variable for the rows, but I have trouble in controlling when the variable should "jump" for the next row to paste the chart.

Any ideas if this is feasible?

Sub PasteCharts()

Dim wb As Workbook
Dim ws As Worksheet
Dim Cht As Chart
Dim Cht_ob As ChartObject

Set wb = ActiveWorkbook

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False


'k is the column number for the address where the chart is to be pasted
k = -1
For Each Cht In wb.Charts

    k = k + 1
    Cht.Activate
    ActiveChart.ChartArea.Select
    ActiveChart.ChartArea.Copy

    Sheets("Gráficos").Select
    Cells(2, (k * 10) + 1).Select
    ActiveSheet.Paste

Next Cht


'Changes the size of each chart pasted in the specific sheet
For Each Cht_ob In Sheets("Gráficos").ChartObjects
With Cht_ob
    .Height = 453.5433070866
    .Width = 453.5433070866

End With

Next Cht_ob


Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True


MsgBox ("All Charts were pasted successfully")
End Sub

Upvotes: 1

Views: 969

Answers (2)

A.S.H
A.S.H

Reputation: 29352

I suggest another method that proceeds directly on the coordinates, not on the cells:

Sub PasteCharts()
    Dim cht As Chart, cht_ob As ChartObject, left As Long, top As Long
    Dim chartWidth As Long, chartHeight As Long, chartsPerRow As Long
    chartWidth = 200: chartHeight = 200: chartsPerRow = 4  ' <-- Set to your choice

    Application.ScreenUpdating = False: Application.EnableEvents = False
    On Error GoTo Cleanup
    For Each cht In ThisWorkbook.Charts
        Set cht_ob = Worksheets("Gráficos").ChartObjects.Add(left, top, chartWidth, chartHeight)
        cht.ChartArea.Copy
        cht_ob.Chart.Paste

        'adjust coordinates for next  chart object
        left = left + chartWidth
        If left > chartsPerRow * chartWidth * 0.99 Then
            left = 0
            top = top + chartHeight
        End If
    Next
    msgBox ("All Charts were pasted successfully")
Cleanup:
    Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub

Upvotes: 1

Shai Rado
Shai Rado

Reputation: 33692

Try the code below, it will copy>>paste all chartsheet in your workbook to "Gráficos" sheet.

Currently, it will paste the odd charts in Column A, and the even charts at Column K (you can modify easily in the code).

The gap between each 2 charts is 30 rows (also can be modified in the code below).

To place a chart in a certain cell, you need to use the ChartObject and use it's .Top and .Left properties.

The syntax to place a chart in Cell A1 is:

Cht_ob.Top = Sheets("Charts").Range("A1").Top

Code 

Option Explicit

Sub PasteCharts()

Dim wb As Workbook
Dim ws As Worksheet
Dim Cht As Chart
Dim Cht_ob As ChartObject
Dim k As Long
Dim ChartRowCount As Long

Set wb = ActiveWorkbook

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

k = 0 ' row number, increment every other 2 charts
ChartRowCount = 1 ' column number, either 1 or 2
For Each Cht In wb.Charts
    Cht.ChartArea.Copy ' copy chart        
    Sheets("Gráficos").Paste ' paste chart

    Set Cht_ob = Sheets("Gráficos").ChartObjects(Sheets("Charts").ChartObjects.Count)  ' set chart object to pasted chart

    With Cht_ob
        If ChartRowCount = 1 Then
            .Top = Sheets("Gráficos").Range("A" & 1 + 30 * k).Top ' modify the top position
            .Left = Sheets("Gráficos").Range("A" & 1 + 30 * k).Left ' modify the left position

            ChartRowCount = ChartRowCount + 1
        Else ' ChartRowCount = 2
            .Top = Sheets("Gráficos").Range("K" & 1 + 30 * k).Top ' modify the top position
            .Left = Sheets("Gráficos").Range("K" & 1 + 30 * k).Left  ' modify the left position

            ChartRowCount = 1
            k = k + 1
        End If

        .Height = 453.5433070866
        .Width = 453.5433070866
    End With
Next Cht

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

MsgBox ("All Charts were pasted successfully")

End Sub

Upvotes: 1

Related Questions