Charts as pictures; file size too long

fredalina

New Member
Joined
Sep 14, 2011
Messages
46
I receive an Excel file with a chart that is driven by 2 drop-down selection boxes. My task is to cycle through all the combinations and generate all the charts, then copy/paste each of them in to PowerPoint at a certain size. I created a macro that cycles through the combinations and creates a new tab for each chart, and then it takes the pictures on each of the tabs and pastes them into a PowerPoint for me. The problem is that the manual process produces a .ppt that is about 3MB and the automated process produces a .ppt that is about 12MB and too large to email at our company (limit is 10MB).

I have tried JPEG, GIF, PNG, BMP, and Advanced Metafile. All produce similarly sized .ppt files. I have tried compressing the file sizes either in Excel or PowerPoint, but the final version is the same size as the original version.

My final result must have the picture formatted to a specific size, and the text (axes, labels) must be legible, but the charts aren't that complicated and can have a slightly lower resolution.

Code:
        'Activate Copy Sheet
    
        Sheets(pLongName).Activate
        Range("A1:B1").Select
        Range("A1:B1").Value = pName
        
    
            
       'Copy to name sheet and name picture
        Sheets("Detailed Pareto").Activate
        Range("A1:B1").Select
        Range("A1:B1").Value = pName
        
      'Copy to name sheet and name picture
        Sheets("Detailed Pareto").Select
         ActiveSheet.ChartObjects("Chart 1").Activate
        ActiveChart.ChartArea.Copy
        Sheets(parName).Select
        ActiveSheet.PasteSpecial Format:="Picture (GIF)", Link:=False, _
            DisplayAsIcon:=False
            

        'Re-size picture
        ActiveSheet.Shapes.Range(Array("Picture 1")).Select
        With Selection
            .Height = 400
            .ShapeRange.LockAspectRatio = msoFalse
            .ShapeRange.ScaleWidth 0.78, msoTrue, msoScaleFromTopLeft
        End With
    
        
        Next i
        Sheets(1).Activate  'Goes to first worksheet
        Application.ScreenUpdating = True  'Makes it visible again
        'If there is an error, go to Screen() and run that
        Application.CommandBars.ExecuteMso "PicturesCompress"

Thanks in advance for any help you can provide.
 

Some videos you may like

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop

Watch MrExcel Video

Forum statistics

Threads
1,127,147
Messages
5,623,008
Members
415,946
Latest member
bellerom

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
Top