group charts and paste as picture

**Mkamilp** · 07-01-2011, 08:02 AM

Hope you might help me in solving my problem.

Here is what I am trying to do..:

I have an excel sheet that has charts…

I found a code to line up the charts in vertical order..
Now I am trying to select each 3 chart as a group like 1 to 3, 3 to 6, 6 to 9 and paste them as picture. My knowledge on vba and coding is quite limited and thats why I am asking ur help

It would be great if u have time to help me on this issue…
Thanks..

Sub LineUpMyCharts()
         Dim MyWidth As Single, MyHeight As Single
         Dim NumWide As Long
         Dim iChtIy As Long, iChtCt As Long, iChtSl As Long
         
         MyWidth = 650
         MyHeight = 180
         NumWide = 3

         iChtCt = ActiveSheet.ChartObjects.Count
         For iChtIy = 1 To iChtCt
             With ActiveSheet.ChartObjects(iChtIy)
                 .Width = MyWidth
                 .Height = MyHeight
                 .Left = (iChtIy)
                 .Top = Int(iChtIy) * (MyHeight)
             End With
         Next

**Andy Pope** · 07-01-2011, 11:55 AM

You don't say what you want to do with the newly created pictures.

Sub LineUpMyCharts()
    Dim MyWidth As Single, MyHeight As Single
    Dim NumWide As Long
    Dim iChtIy As Long, iChtCt As Long, iChtSl As Long
    Dim strName As String
    Dim sngLeft As Single
    Dim sngTop As Single
    Dim lngChartPerRow As Long
    Dim lngChartPerGroup As Long
    
    MyWidth = 650
    MyHeight = 180
    NumWide = 3

    sngLeft = 1
    sngTop = MyHeight
    strName = ""

    lngChartPerRow = 1
    lngChartPerGroup = 3
    
    iChtCt = ActiveSheet.ChartObjects.Count
    For iChtIy = 1 To iChtCt
        With ActiveSheet.ChartObjects(iChtIy)
            .Width = MyWidth
            .Height = MyHeight
            .Left = sngLeft
            .Top = sngTop
        
            strName = strName & .Name & ","
        
        End With
        
        If iChtIy Mod lngChartPerRow = 0 Then
            sngTop = sngTop + MyHeight
            sngLeft = 1
        Else
            sngLeft = sngLeft + MyWidth
        End If
        
        If iChtIy Mod lngChartPerGroup = 0 Then
            strName = Left(strName, Len(strName) - 1)
            With ActiveSheet
                With .Shapes.Range(Split(strName, ",")).Group
                    .CopyPicture
                    .Ungroup
                End With
                .Paste
            End With
            strName = ""
        End If
        
    Next
    
End Sub

**Mkamilp** · 07-01-2011, 01:25 PM

This really works

Thanks alot....

Well let me explain what I am trying to do as a whole...

I have too many charts on an excel sheet and I copy them to powerpoint everymonth..It was taking me like 2 days to copy,paste,set location and prepare the presentation doc.

After getting familiar with VBA I thought I can compile a macro to help in doing these presentations...

Since there are too many charts I dont want to paste them as an excelchart. Instead I group each 3 chart and paste as picture on one slide.

After my research on net I found a code to copy excel charts to powerpoint but it :

1-copy and paste them as excel chart which I dont prefer to do.
2- Paste one chart on each powerpoint slide by centerally positioning it on slide.

if I can link these two codes to each other..I mean if these excel to powerpoint macro can copy those pictures to slides in order, it will be amazing...

Here is the code that I found for transferring excel charts to powerpoint.

Sub CreateNewPowerPointPresentation()
' add a reference to the PowerPoint-library this is done from the Tools ---> References menu path and you
'need to find the microsoft powerpoint check box and check it. Then excel can use ppt objects within itself

Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.slide
Dim pptShape As PowerPoint.Shape
Dim i As Integer, strString As String
Dim Graphcount As Integer

Count = 0 'initialise count variable
i = 1
Graphcount = Worksheets("kişiler").ChartObjects.Count

Set pptApp = CreateObject("PowerPoint.Application")
Set pptPres = pptApp.Presentations.Add(msoTrue) ' create a new presentation

Do While i < Graphcount ' starts a loop to copy charts
ActiveSheet.ChartObjects(i).Activate ' selects the chart object by its index number
ActiveChart.ChartArea.Select
ActiveChart.ChartArea.Copy

With pptPres.Slides
Set pptSlide = .Add(.Count + 1, ppLayoutTitleOnly) ' add a slide
End With
With pptSlide
.Shapes(1).TextFrame.TextRange.Text = "Slide Title" 
.Shapes.PasteSpecial ppPasteDefault
With .Shapes(.Shapes.Count) ' sizes the graph on the slide
.Left = 120
.Top = 125.125
.Width = 480
.Height = 289.625
End With
End With

Application.CutCopyMode = False ' end cut/copy from Excel
Set pptSlide = Nothing
i = i + 1 ' increment the graph count to copy the next chart on the excel sheet
Loop

On Error Resume Next

On Error GoTo 0 
Set pptPres = Nothing

pptApp.Visible = True
'pptApp.Quit 
Set pptApp = Nothing

End Sub

I attached the simplified version of the file I am working on.. it probably better explains what I am trying to do..

**Andy Pope** · 07-02-2011, 07:17 AM

 Sub LineUpMyCharts(Pres As PowerPoint.Presentation)
    Dim MyWidth As Single, MyHeight As Single
    Dim NumWide As Long
    Dim iChtIy As Long, iChtCt As Long, iChtSl As Long
    Dim strName As String
    Dim sngLeft As Single
    Dim sngTop As Single
    Dim lngChartPerRow As Long
    Dim lngChartPerGroup As Long
    Dim shpChtPic As ShapeRange
    
    MyWidth = 650
    MyHeight = 180
    NumWide = 3

    sngLeft = 1
    sngTop = MyHeight
    strName = ""

    lngChartPerRow = 1
    lngChartPerGroup = 3
    
    iChtCt = ActiveSheet.ChartObjects.Count
    For iChtIy = 1 To iChtCt
        With ActiveSheet.ChartObjects(iChtIy)
            .Width = MyWidth
            .Height = MyHeight
            .Left = sngLeft
            .Top = sngTop
        
            strName = strName & .Name & ","
        
        End With
        
        If iChtIy Mod lngChartPerRow = 0 Then
            sngTop = sngTop + MyHeight
            sngLeft = 1
        Else
            sngLeft = sngLeft + MyWidth
        End If
        
        If iChtIy Mod lngChartPerGroup = 0 Then
            strName = Left(strName, Len(strName) - 1)
            
            Set shpChtPic = ActiveSheet.Shapes.Range(Split(strName, ","))
            shpChtPic.Group
                
            ChartToPPT Pres, shpChtPic
            shpChtPic.Ungroup
            
            strName = ""
        End If
        
    Next
    
End Sub
Sub ChartToPPT(Pres As PowerPoint.Presentation, ChartPic As ShapeRange)
' to test this code, paste it into an Excel module
' add a reference to the PowerPoint-library this is done from the Tools ---> References menu path and you
'need to find the microsoft powerpoint check box and check it. Then excel can use ppt objects within itself
    Dim pptSlide As PowerPoint.slide
    Dim pptShape As PowerPoint.Shape

    With Pres.Slides
        Set pptSlide = .Add(.Count + 1, ppLayoutTitleOnly)
        
        ChartPic.Parent.Shapes(ChartPic.Name).CopyPicture
        
        With pptSlide
            .Shapes(1).TextFrame.TextRange.Text = "Slide Title"
            .Shapes.PasteSpecial ppPasteDefault
            With .Shapes(.Shapes.Count)
                .Left = 120
                .Top = 125.125
                .Width = 480
                .Height = 289.625
            End With
        End With
    End With

End Sub
Sub Main()

    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation

    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    Set pptPres = pptApp.Presentations.Add(msoTrue)

    LineUpMyCharts pptPres
    
    Set pptPres = Nothing
End Sub

**Mkamilp** · 07-03-2011, 02:05 PM

Especially after struggling too long on doing these slides manually its awesome to watch everything running with a code...Thanks alot Andy..!!

I think I have problem with the code...I tried last night at home and it ws working properly( I have office 2007 installed on my laptop). When I tried the code at office (office 2010) it start running but did not work properly... it highlights " .Shapes.PasteSpecial ppPasteDefault " and attached Debug secreen appears..

What should I do?