Copying graphs from multiple Excel Worksheets onto Powerpoint

d1e9v85

New Member
Joined
May 1, 2018
Messages
11
Hello All,

I am an VBA noob looking for help from the experts here.
Essentially what I am trying to do here is:

I have an Excel workbook with multiple sheets, some of those sheets have graphs in them, some sheets have 3-6 graphs in them.

What I want to do via vba code is: go through all of the worksheets and paste the graphs from each worksheet into one slide.

For ex: if worksheet 1 has 3 graphs, then that should copy over to slide 1 of the ppt. if worksheet 2 has 4 graphs, they should all go to slide 2.

Lastly, I want to have a maximum of 4 graphs per slide.

Below is what I am starting with. (very very basic)

Thanks for your help!

Code:
Option Explicit

'Declaring the necessary Power Point variables (are used in both subs).
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim strFileToOpen As Variant, sh As Worksheet, ch As ChartObject
Dim pptSlideCount As Integer


Sub ChartsToPowerPoint()


    'Exports all the chart sheets to a new power point presentation.
    'It also adds a text box with the chart title.
    
    Dim ws As Worksheet
    Dim intChNum As Integer
    Dim objCh As Object
    
    'Count the embedded charts.
    For Each ws In ActiveWorkbook.Worksheets
        intChNum = intChNum + ws.ChartObjects.Count
    Next ws
    
    'Check if there are chart (embedded or not) in the active workbook.
    If intChNum + ActiveWorkbook.Charts.Count < 1 Then
        MsgBox "Sorry, there are no charts to export!", vbCritical, "Ops"
        Exit Sub
    End If
    
    'Open PowerPoint and create a new presentation.
    strFileToOpen = Application.GetOpenFilename(FileFilter:="Powerpoint Files *.pptx (*.pptx),")
    If strFileToOpen = False Then Exit Sub
    Set pptApp = New PowerPoint.Application
    pptApp.Visible = True
    Set pptPres = pptApp.Presentations.Open(Filename:=strFileToOpen, ReadOnly:=msoFalse)
    
    'Loop through all the embedded charts in all worksheets.
    For Each ws In ActiveWorkbook.Worksheets
        For Each objCh In ws.ChartObjects
            Call pptFormat(objCh.Chart)
        Next objCh
    Next ws
    
    'Loop through all the chart sheets.
    For Each objCh In ActiveWorkbook.Charts
        Call pptFormat(objCh)
    Next objCh
    
    'Show the power point.
    pptApp.Visible = True


    'Cleanup the objects.
    Set pptSlide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
    
    'Infrom the user that the macro finished.
    MsgBox "The charts were copied successfully to the new presentation!", vbInformation, "Done"
    
End Sub


Private Sub pptFormat(xlCh As Chart)
    
    
    Dim chTitle As String
    Dim j As Integer
    
    On Error Resume Next
   'Get the chart title and copy the chart area.
    chTitle = xlCh.ChartTitle.Text
    xlCh.ChartArea.Copy


    'Count the slides and add a new one after the last slide.
    pptSlideCount = pptPres.Slides.Count
    Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
    
    'Paste the chart and create a new textbox.
    pptSlide.Shapes.PasteSpecial ppPasteJPG
    If chTitle <> "" Then
        pptSlide.Shapes.AddTextbox msoTextOrientationHorizontal, 12.5, 20, 894.75, 155.25
    End If
                    
    'Format the picture and the textbox.
    For j = 1 To pptSlide.Shapes.Count
        With pptSlide.Shapes(j)
            'Picture position.
            If .Type = msoPicture Then
                .Top = 75


            End If
            'Text box position and formamt.
            If .Type = msoTextBox Then
                With .TextFrame.TextRange
                    .ParagraphFormat.Alignment = ppAlignCenter
                    .Text = chTitle
                    .Font.Name = "Calibri"
                    .Font.Size = 44
                    .Font.Bold = msoTrue
                    .Font.Color = RGB(153, 153, 153)
                End With
            End If
        End With
    Next j


End Sub
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.

Forum statistics

Threads
1,223,229
Messages
6,170,881
Members
452,364
Latest member
springate

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top