Powerpoint chart update from Excel. VBA

[help_for_excel]

I want to update chart in powerpoint 2010 from Excel 2010. Code looks for name of range in excel and if same range name is found on power point slide it updates chart with data from excel.

Problem is this code is not working in 2010, can you please help. Help with making this code work in 2010


Option Explicit

Private Const NAMED_RANGE_PREFIX = "Export_"
Private Const NAMED_RANGE_PREFIX_TEXT = "ExportText"

Private m_sLog As String

Private Sub CommandButton1_Click()
On Error GoTo Catch
Dim pptApp As PowerPoint.Application
Dim pptPresentation As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape

Dim mgrChart As Graph.Chart
Dim mgrDatasheet As Graph.DataSheet

Dim rngData As Excel.Range

Dim iRow As Long, iCol As Long
Dim sTag As String
Dim nFound As Long, nUpdated As Long
Dim nFoundText As Long, nUpdatedText As Long

Dim i As Integer

Dim fLog As frmLog

Dim Box1Status As VbMsgBoxResult

m_sLog = ""

'Prompt to Export
Box1Status = MsgBox("Export and Save to Powerpoint Template?" & Chr(13) & "Reminder: Please use a clean template for export and be sure to back up the template beforehand. " & Chr(13) & Chr(13) & "PLEASE SAVE ANY OTHER OPEN POWERPOINT DOCUMENTS AS ALL UNSAVED WORK WILL BE LOST!", vbQuestion + vbYesNo, "Confirm Export")
If Box1Status = vbNo Then Exit Sub


i = 1

UpdateStatus "Opening Powerpoint presentation '" & Range("fileloc")
Set pptApp = New PowerPoint.Application
pptApp.Activate
Set pptPresentation = pptApp.Presentations.Open(Range("fileloc"))
pptApp.WindowState = ppWindowMinimized

'Looks for (tagged) charts to update

UpdateStatus "Searching presentation for charts..."
For Each pptSlide In pptPresentation.Slides

For Each pptShape In pptSlide.Shapes
If pptShape.Type = msoEmbeddedOLEObject Then
' Possibly a chart
If TypeOf pptShape.OLEFormat.Object Is Graph.Chart Then
' Definately a chart--see if we have a named range for it
nFound = nFound + 1
Set mgrChart = pptShape.OLEFormat.Object
Set mgrDatasheet = mgrChart.Application.DataSheet
With mgrDatasheet
sTag = .Cells(1, 1)
If Left(sTag, 6) = "Export" Then UpdateStatus "Found chart on slide '" & pptSlide.SlideNumber & "' with tag '" & sTag & "'. Searching Excel workbook for same tag..."
Set rngData = RangeForChart(sTag)
If rngData Is Nothing Then
' This chart has no data in this Excel workbook
If Left(sTag, 6) <> "Export" Then
UpdateStatus "Found chart on slide '" & pptSlide.SlideNumber & "' with no tag, skipping"
Else
UpdateStatus "'" & sTag & "' does not exist in workbook, skipping."
End If
Else
' Update the PowerPoint chart with the Excel data
UpdateStatus "Found '" & sTag & "' at named range '" & rngData.Name & "'. Updating presentation..."
.Cells.ClearContents
For iRow = 0 To rngData.Rows.Count - 1
For iCol = 0 To rngData.Columns.Count - 1
.Cells(iRow + 1, iCol + 1) = rngData.Cells(iRow + 1, iCol + 1)
Next iCol
Next iRow
.Application.Update
UpdateStatus "Chart with tag '" & sTag & "' updated."
nUpdated = nUpdated + 1
End If
End With
Set mgrDatasheet = Nothing
mgrChart.Application.Quit
Set mgrChart = Nothing
End If
End If
Next pptShape
i = i + 1
Next pptSlide


UpdateStatus "Finished searching presentation. Closing PowerPoint."

pptPresentation.Save
pptPresentation.Close
Set pptPresentation = Nothing
pptApp.Quit
Set pptApp = Nothing

UpdateStatus "Done. " & nFound & " charts found and " & nUpdated & " charts updated. " & nFoundText & " text boxes found and " & nUpdatedText & " text boxes updated."

Set fLog = New frmLog
fLog.Caption = "Update of Powerpoint Template Complete"
fLog.txtLog.Text = m_sLog
fLog.Show
Unload fLog
Set fLog = Nothing
Exit Sub

Catch:
MsgBox "An unexpected error occurred while updating: " & Err.Number & " " & Err.Description, vbCritical
ForceCleanup mgrChart, mgrDatasheet, pptPresentation, pptApp
End Sub

Private Property Get RangeForChart(sTag As String) As Range
Dim sChartTag As String
Dim iUpdate As Long
Dim NameList As Range
'Dim nRow As Range

Set NameList = Range("Name_List")

If Left(sTag, 6) <> "Export" Then Exit Property

'For Each nRow In NameList.Rows
Do While sChartTag <> sTag

iUpdate = iUpdate + 1
' This will error if there is no named range for "Export_", which means that sTag does not
' exist in the workbook so return nothing
On Error Resume Next
sChartTag = ActiveWorkbook.Names(NAMED_RANGE_PREFIX & NameList(iUpdate, 1).Value).RefersToRange.Cells(1, 1)
If Err.Number <> 0 Then
' Return nothing
Exit Property
End If
On Error GoTo 0
Loop
'Next nRow


Set RangeForChart = ActiveWorkbook.Names(NAMED_RANGE_PREFIX & NameList(iUpdate, 1).Value).RefersToRange

End Property

Private Property Get RangeForText(sTag As String) As Range
Dim sTextTag As String
Dim iUpdate As Long

If Left(sTag, 10) <> "ExportText" Then Exit Property

Do While sTextTag <> sTag
iUpdate = iUpdate + 1
' This will error if there is no named range for "ExportText" & iUpdate, which means that sTag does not
' exist in the workbook so return nothing
On Error Resume Next
sTextTag = NAMED_RANGE_PREFIX_TEXT & iUpdate
If Err.Number <> 0 Then
' Return nothing
Exit Property
End If
On Error GoTo 0
Loop

Set RangeForText = ActiveWorkbook.Names(NAMED_RANGE_PREFIX_TEXT & iUpdate).RefersToRange

End Property

Private Sub UpdateStatus(sMessage As String)
m_sLog = m_sLog & Now() & ": " & sMessage & vbNewLine
Application.StatusBar = Now() & ": " & sMessage
DoEvents
End Sub

Private Sub ForceCleanup(mgrChart As Graph.Chart, mgrDatasheet As Graph.DataSheet, pptPresentation As PowerPoint.Presentation, pptApp As PowerPoint.Application)
On Error Resume Next
mgrChart.Application.Quit
Set mgrChart = Nothing
mgrDatasheet.Application.Quit
Set mgrDatasheet = Nothing
pptPresentation.Close
Set pptPresentation = Nothing
pptApp.Quit
Set pptApp = Nothing
End Sub