change order of graphs when using macro to export all excel charts to powerpoint

Hi all,

I've been using a VBA code to look through my spreadsheet and find any graphs in any tab and move it to powerpoint. I have about 70 tabs with 7 graphs each.
Issue I have is that the order of the graphs in the slidepack isn't in the same as found on each excel tab.
I also tried renaming them (chart1-chart7) but problem still remains.
Has anybody have any suggestions? Really appreciate any help. Thanks

Originally Posted by mrice

I guess that you are hoping for charts to be read left to right and then top to bottom. If so, you can get the cell number like this

((Activesheet.chartobjects(1).topleftCell.row-1) * Activesheet.columns.count) + Activesheet.chartobjects(1).topleftCell.column

Sorting by this would then give you the desired order.

Hi Martin,
Thank you for your quick response! Much appreciated! However my VBA knowledge is limited and I am having trouble to integrate your solution in my code.
I attached the code below. If you could suggest where exactly to put your statement would be great. Thanks

Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
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
    If ws.Visible <> 0 Then
        intChNum = intChNum + ws.ChartObjects.Count
    End If
    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.
    Set pptApp = New PowerPoint.Application
    Set pptPres = pptApp.Presentations.Add
    
    'Loop through all the embedded charts in all worksheets.
    
        For Each ws In ActiveWorkbook.Worksheets
        If ws.Visible <> 0 Then
        For Each objCh In ws.ChartObjects
            Call pptFormat(objCh.Chart)
        Next objCh
        End If
        Next ws
    
    
    'Loop through all the chart sheets.
    For Each objCh In ActiveWorkbook.Charts
    If ws.Visible <> 0 Then
        Call pptFormat(objCh)
    End If
    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)
    
    'Formats the charts/pictures and the chart titles/textboxes.
       
    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, 694.75, 55.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 = 87.84976
                .Left = 33.98417
                .Height = 422.7964
                .Width = 646.5262
            End If
            'Text box position and formamt.
            If .Type = msoTextBox Then
                With .TextFrame.TextRange
                    .ParagraphFormat.Alignment = ppAlignCenter
                    .Text = chTitle
                    .Font.Name = "Tahoma (Headings)"
                    .Font.Size = 28
                    .Font.Bold = msoTrue
                End With
            End If
        End With
    Next j
    
  End Sub

Thanks again

Originally Posted by mrice

I guess that you are hoping for charts to be read left to right and then top to bottom. If so, you can get the cell number like this

((Activesheet.chartobjects(1).topleftCell.row-1) * Activesheet.columns.count) + Activesheet.chartobjects(1).topleftCell.column

Sorting by this would then give you the desired order.

Hi Martin,
Thank you for your quick response! Much appreciated! However my VBA knowledge is limited and I am having trouble to integrate your solution in my code.
I attached the code below. If you could suggest where exactly to put your statement would be great. Thanks

Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
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
    If ws.Visible <> 0 Then
        intChNum = intChNum + ws.ChartObjects.Count
    End If
    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.
    Set pptApp = New PowerPoint.Application
    Set pptPres = pptApp.Presentations.Add
    
    'Loop through all the embedded charts in all worksheets.
    
        For Each ws In ActiveWorkbook.Worksheets
        If ws.Visible <> 0 Then
        For Each objCh In ws.ChartObjects
            Call pptFormat(objCh.Chart)
        Next objCh
        End If
        Next ws
    
    
    'Loop through all the chart sheets.
    For Each objCh In ActiveWorkbook.Charts
    If ws.Visible <> 0 Then
        Call pptFormat(objCh)
    End If
    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)
    
    'Formats the charts/pictures and the chart titles/textboxes.
       
    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, 694.75, 55.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 = 87.84976
                .Left = 33.98417
                .Height = 422.7964
                .Width = 646.5262
            End If
            'Text box position and formamt.
            If .Type = msoTextBox Then
                With .TextFrame.TextRange
                    .ParagraphFormat.Alignment = ppAlignCenter
                    .Text = chTitle
                    .Font.Name = "Tahoma (Headings)"
                    .Font.Size = 28
                    .Font.Bold = msoTrue
                End With
            End If
        End With
    Next j
    
  End Sub

Thanks again