Gfrktyl

I have written excel vba script that updates 250 charts in PowerPoint with data from an excel table. The powerpoint has 149 slides and 80 slides have charts. The problem is the script takes ages running and crashes at times. I have tried reducing the chart slides to 20 slides but still no difference. Plus is there a way to save the powerpoint presentation as is instead of saving it as a different file with a different format. Whenever I try to save it as is, I get an error saying the file is read-only. Thanks for the help in advance

Sub updateppt()



Dim myppt As PowerPoint.Presentation

Dim mypptslide As PowerPoint.slide

Dim mypptshape As PowerPoint.shape

Dim mypptchrt As PowerPoint.chart

Dim mypptchrtdta As PowerPoint.ChartData

Dim cTable As Excel.ListObject

Dim mypptApp As PowerPoint.Application

Dim wb As Excel.Workbook

Dim ws As Excel.Worksheet

Dim shape As Object

Dim slide As Object

Dim FileName As String

Dim lastRow As Range

Dim rng As Range

Dim rng2 As Range



Update_display (False)

Application.Calculation = xlCalculateManual

FileName = ".....test2.pptx"



Set mypptApp = CreateObject("PowerPoint.Application")

Set myppt = mypptApp.Presentations.Open(FileName, WithWindow:=msoFalse)





'set the worksheet where to retrieve the data from 

Set wb = ActiveWorkbook

Set ws = wb.Worksheets(3)



'initialize the counter

i = 2



'Loop to go through slides,look for charts then update them

For Each slide In myppt.Slides



    For Each shape In slide.Shapes



        If shape.HasChart Then

        Set chart = shape.chart

        Set mypptchrtdta = chart.ChartData

        Set cTable = mypptchrtdta.Workbook.Worksheets(1).ListObjects("Table1")





        'range of the datato be pasted

        Set rng = ws.ListObjects(1).Range.Cells(i, 1)

        Set rng2 = ws.ListObjects(1).Range.Cells(i, 2)



        'pasting the data

        cTable.ListRows.Add AlwaysInsert:=True

        cTable.Range.End(xlDown).Offset(1, 0).Value = rng.Value

        cTable.Range.End(xlDown).Offset(0, 1).Value = rng2.Value

        i = i + 1



        End If



    Next



Next

Update_display (True)

Application.Calculation = xlCalculateAutomatic



myppt.SaveAs FileName, ppSaveAsOpenXMLPresentation



i = i - 1

MsgBox Prompt:=i & " Charts have been updated", Buttons:=vbInformation



mypptApp.Quit

End Sub



'sub to deal with popups

Sub Update_display(bSwitch As Boolean)



Application.ScreenUpdating = bSwitch

Application.EnableEvents = bSwitch

Application.DisplayAlerts = bSwitch

Application.DisplayPasteOptions = bSwitch

Application.ScreenUpdating = bSwitch

Application.DisplayStatusBar = bSwitch



End Sub