How does behave then?
Sub Chart___Testing_Revised_V6()
' Object Declarations
Dim oPres As Presentation
Dim oSlide As Slide
Dim oShape As Shape
Dim myChart As PowerPoint.Chart
Dim Wb As Object ' Late binding: Can hold Excel.Workbook or OLEObject
Dim excelApp As Object ' Excel.Application object
Dim TempSheet As Object ' Temporary worksheet object
Dim Tb As Shape ' Textbox Shape object
' Variable Declarations
Dim answer As Integer
Dim ExecFlag As Boolean
Dim wsName As String
Dim loName As String
Dim errNum As Long
' Constants
Const PROC_NAME As String = "Chart___Testing_Revised_V6" ' For error handling
Const ERR_XL_APP_NOT_FOUND = 429 'Constant for Excel not found Error
'## Main Procedure
On Error GoTo ErrorHandler ' Enable error handling
' Get Presentation Object
Set oPres = ActivePresentation
' Prompt User for Confirmation
answer = MsgBox( _
"This macro will update linked data in all charts and embedded Excels." & vbCrLf & "It will also update dynamic tables named 'Data'/'Table1' in 'Data'/'Sheet1' sheets." & vbCrLf & _
"IMPORTANT: This macro does NOT work on GROUPED CHARTS." & vbCrLf & "BACKUP YOUR PRESENTATION FILE BEFORE RUNNING THIS MACRO." & vbCrLf & _
"Continue?", vbQuestion + vbYesNo + vbDefaultButton2, "WARNING: Data Update Macro" )
' Exit if User Cancels
If answer = vbNo Then
Exit Sub ' Use Exit Sub for a cleaner exit
End If
' Get or Create Excel Application Object
'#Attempt to get an existing instance. If none exists, create a new one.
On Error Resume Next
Set excelApp = GetObject(, "Excel.Application")
errNum = Err.Number
On Error GoTo 0
If errNum = ERR_XL_APP_NOT_FOUND Then 'Use constant
Set excelApp = CreateObject("Excel.Application")
ElseIf errNum <> 0 Then
' Handle other errors during GetObject.
GoTo ErrorHandler
End If
' Configure Excel Application
excelApp.Visible = False ' Run in the background
excelApp.DisplayAlerts = False ' Suppress prompts
' Loop Through Slides and Shapes
For Each oSlide In oPres.Slides
oSlide.Select 'Potentially needed for .Activate, but try to minimize use of Select/Activate
For Each oShape In oSlide.Shapes
ExecFlag = False ' Reset flag for each shape
' Handle Charts and Embedded Excel Objects
If oShape.HasChart Then
Set myChart = oShape.Chart
myChart.ChartData.Activate 'Use Activate
ExecFlag = True
ElseIf oShape.Type = msoEmbeddedOLEObject Then
Set Wb = oShape.OLEFormat.Object
If TypeName(Wb) = "Workbook" Then
oShape.OLEFormat.Activate 'Use Activate
ExecFlag = True
End If
End If
' Process Excel Objects (Charts or Embedded)
If ExecFlag Then
Set Wb = excelApp.ActiveWorkbook ' Get the active workbook
' "Fake" Step: Activate a Worksheet (with error handling)
On Error Resume Next
Set TempSheet = Wb.Worksheets(1) ' Try the first sheet
If Not TempSheet Is Nothing Then
TempSheet.Activate
Else
Set TempSheet = Wb.Sheets.Add ' Add a sheet if no sheets exist
TempSheet.Activate
End If
On Error GoTo 0
' Update Links, Modify Data, and Update Tables (with error handling)
On Error Resume Next
Wb.UpdateLink Name:=Wb.LinkSources ' Update links
Wb.Worksheets("Data").Range("BZ1").Value = "AABBDED" ' Modify cell value
Wb.Worksheets("Data").Range("A1:M50").Replace "Apple", "Banana" ' Search/replace
' Update List Object Filters (Consolidated and Improved)
For Each wsName In Array("Data", "Sheet1")
For Each loName In Array("Data", "Table1")
' Construct sheet and listobject names, and handle errors robustly
On Error Resume Next
With Wb
If .Worksheets(wsName) Is Nothing Then
GoTo NextLO 'If worksheet doesn't exist, go to the next listobject
End If
If .Worksheets(wsName).ListObjects(loName) Is Nothing Then
GoTo NextLO 'If listobject doesn't exist, go to the next listobject
End If
.Worksheets(wsName).ListObjects(loName).Range.AutoFilter Field:=1, Criteria1:="<>0"
End With
NextLO:
On Error GoTo 0
Next loName
Next wsName
On Error GoTo 0
Wb.RefreshAll ' Refresh all connections
Wb.Close SaveChanges:=False ' Close without saving changes
Set Wb = Nothing
' Add "Updated Data" Textbox
Set Tb = oSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, oShape.Left, oShape.Top, 100, 25)
With Tb
.Name = "Delete_" & oShape.Name
.Fill.ForeColor.RGB = RGB(255, 255, 0)
.TextFrame.TextRange.Text = "Updated Data"
.TextFrame.TextRange.Font.Size = 8
.Select 'Consider if you really need to select.
End With
Set Tb = Nothing 'Clean up
End If ' End If ExecFlag
Next oShape
Next oSlide
CleanUp:
On Error Resume Next
'## 13. Clean Up Excel Application
If Not excelApp Is Nothing Then
excelApp.DisplayAlerts = True
excelApp.Quit ' Quit Excel
Set excelApp = Nothing ' Release object
End If
On Error GoTo 0
Exit Sub ' Use Exit Sub for normal termination
ErrorHandler:
Dim errDesc As String
errNum = Err.Number
errDesc = Err.Description
If errNum <> 0 Then
MsgBox "Error in " & PROC_NAME & ":" & vbCrLf & "Error Number: " & errNum & vbCrLf & "Description: " & errDesc, vbCritical, "Application Error"
End If
' Resume CleanUp ' Moved to before Exit Sub
Resume CleanUp ' Ensure cleanup is executed
End Sub
Search and Replace Embedded Chart in PowerPoint
Reply With Quote
