Search and Replace Embedded Chart in PowerPoint

[yurble_vn]

Dear All,

I created a vba to work with Chart/Embedded Chart in Powerpoint: Update Linked Data, Edit a Particular Cell, and Do Search and Replace.

For PowerPoint Native Charts: My code works well for all native charts in PowerPoint.
For Embedded charts: My codes worked well for "update linked data". But, it can only do "search and replace", "Edit cell" for embedded object in first slide. From 2nd slide onward, it does NOT do search and replace or edit the excel embedded object. I put two embedded charts in 1st slide, both got updated. But from 2nd slide onward, this VBA did not open the object in excel. This is quite weird...

Appreciate your help to advise:


Sub Chart___Testing()

Dim oPres As Presentation
Dim oSlide As Slide
Dim oShape As Shape
Dim myChart As PowerPoint.Chart
Dim Wb, Tb As Object
Dim excelApplication As Object
Dim LastYear As String
Dim ThisYear As String
Dim oSheet As Object

Dim answer As Integer
Dim execFlag As Boolean

answer = MsgBox("This Macro will ...., Continue?")

If answer = vbNo Then
GoTo ErrorHandler
End If

' Get the active presentation
Set oPres = ActivePresentation

' Loop through each slide
For Each oSlide In oPres.Slides
' Loop through each shape on the slide

For Each oShape In oSlide.Shapes
If oShape.HasChart Then
Set myChart = oShape.Chart
myChart.ChartData.Activate
'Get Excel App
Set excelApplication = GetObject(, "Excel.Application")
Set Wb = excelApplication.ActiveWorkbook


On Error Resume Next
Wb.Worksheets("Data").Range("A1:M50").Replace "Apple", "Banana"

On Error Resume Next
Wb.UpdateLink Name:=Wb.LinkSources


'Check if this is a Gain and Loss chart
If Wb.Worksheets("Data").Range("AA1").Value = "GainandLoss" Then
Wb.Worksheets("Data").Range("AB1").Value = 9
Wb.Worksheets("Data").Range("AC1").Value = 9
'Put A Updated Textbox
Set Tb = oSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=oShape.Left, Top:=oShape.Top, Width:=100, Height:=25)
Tb.Name = "Delete_" & oShape.Name
Tb.Fill.ForeColor.RGB = RGB(255, 255, 0)
Tb.TextFrame.TextRange.Text = "Updated"
Tb.TextFrame.TextRange.Font.Size = 8
End If
Wb.Close (0)


Else
If oShape.Type = msoEmbeddedOLEObject Then
Set Wb = oShape.OLEFormat.Object
On Error Resume Next
'Check if the OLE object is an Excel Workbook
If TypeName(Wb) = "Workbook" Then
'Open Embedded Excel with option '2' (open in excel)
nCount = 0
For Each sVerb In oShape.OLEFormat.ObjectVerbs
nCount = nCount + 1
If sVerb = "Open" Then
oShape.OLEFormat.DoVerb nCount
End If
Next sVerb
'Get Excel App
Set excelApplication = GetObject(, "Excel.Application")
Set Wb = excelApplication.ActiveWorkbook
'
On Error Resume Next
Wb.Worksheets("Data").Range("A1:M50").Replace "Apple", "Banana"

On Error Resume Next
Wb.UpdateLink Name:=Wb.LinkSources

'Change Cell A1 value
Wb.Worksheets("Data").Range("A1").Value = "AA"
Wb.Close (0)

'Put A Updated Textbox
Set Wb = oSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=oShape.Left, Top:=oShape.Top, Width:=100, Height:=25)
Wb.Select
Wb.Name = "Delete_" & oShape.Name
Wb.Fill.ForeColor.RGB = RGB(255, 255, 0)
Wb.TextFrame.TextRange.Text = "Updated New link: " & NewAddress
Wb.TextFrame.TextRange.Font.Size = 8
End If
End If
End If
Next oShape

Next oSlide
ErrorHandler:
MsgBox "Finish!"
End Sub

[Aussiebear]

It looks like the issue might stem from how the code interacts with the embedded Excel charts and OLE objects. Specifically, the repeated use of GetObject(, "Excel.Application") within the loops could be causing problems.

Here's a breakdown of potential issues and how to address them:




Leaving Excel Instances Open: The code activates the chart data in Excel and opens embedded Excel objects but then closes the workbooks (Wb.Close (0)). However, it doesn't explicitly quit the Excel application object (excelApplication). This could lead to multiple instances of Excel running in the background, potentially interfering with subsequent attempts to access embedded objects on later slides.
Race Conditions or Timing: When dealing with COM objects like Excel, sometimes operations might not complete instantaneously. Repeatedly getting the active Excel application and immediately trying to interact with its workbooks might lead to errors if the application hasn't fully initialized or if the correct workbook isn't yet active.
Scope of excelApplication: While excelApplication is declared at the top of the sub, it's repeatedly set within the loops. It might be more efficient to set it once at the beginning if needed for the entire process. However, the core issue is likely the failure to properly manage the Excel application instance.





Sub Chart___Testing_Revised()
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 either Excel.Workbook or OLEObject
Dim excelApp As Object
' To hold the Excel application object
'Dim excelApplication As Object
' Removed redundant declaration
Dim LastYear As String
Dim ThisYear As String
Dim oSheet As Object
Dim answer As Integer
Dim execFlag As Boolean
answer = MsgBox("This Macro will ...., Continue?")
If answer = vbNo Then
GoTo ErrorHandler
End If
' Get the active presentation
Set oPres = ActivePresentation
' Attempt to get an existing Excel instance, or create a new one if none exists
On Error Resume Next
Set excelApp = GetObject(, "Excel.Application")
On Error GoTo 0
If excelApp Is Nothing Then
Set excelApp = CreateObject("Excel.Application")
End If
' Keep Excel hidden unless explicitly needed for user interaction
excelApp.Visible = False
excelApp.DisplayAlerts = False
' To prevent prompts
' Loop through each slide
For Each oSlide In oPres.Slides
' Loop through each shape on the slide
For Each oShape In oSlide.Shapes
If oShape.HasChart Then
Set myChart = oShape.Chart
myChart.ChartData.Activate
' Set the active workbook
Set Wb = excelApp.ActiveWorkbook
On Error Resume Next
Wb.Worksheets("Data").Range("A1:M50").Replace "Apple", "Banana"
On Error GoTo 0
' Turn error handling back on
On Error Resume Next
Wb.UpdateLink Name:=Wb.LinkSources
On Error GoTo 0
' Check if this is a Gain and Loss chart
If Wb.Worksheets("Data").Range("AA1").Value = "GainandLoss" Then
Wb.Worksheets("Data").Range("AB1").Value = 9
Wb.Worksheets("Data").Range("AC1").Value = 9
' Put A Updated Textbox
Dim Tb As Shape
' Declare Tb here to limit scope
Set Tb = oSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=oShape.Left, Top:=oShape.Top, Width:=100, Height:=25)
Tb.Name = "Delete_" & oShape.Name
Tb.Fill.ForeColor.RGB = RGB(255, 255, 0)
Tb.TextFrame.TextRange.Text = "Updated"
Tb.TextFrame.TextRange.Font.Size = 8
End If
Wb.Close SaveChanges:=False
' Specify not to save changes
ElseIf
oShape.Type = msoEmbeddedOLEObject Then
On Error Resume Next
Set Wb = oShape.OLEFormat.Object
On Error GoTo 0
' Check if the OLE object is an Excel Workbook
If TypeName(Wb) = "Workbook" Then
' No need to explicitly open using DoVerb if we have the object
On Error Resume Next
Wb.Worksheets("Data").Range("A1:M50").Replace "Apple", "Banana"
On Error GoTo 0
On Error Resume Next
Wb.UpdateLink Name:=Wb.LinkSources
On Error GoTo 0
' Change Cell A1 value
Wb.Worksheets("Data").Range("A1").Value = "AA"
Wb.Close SaveChanges:=False ' Specify not to save changes
' Put A Updated Textbox
Dim Tb As Shape
' Declare Tb here to limit scope
Set Tb = oSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=oShape.Left, Top:=oShape.Top, Width:=100, Height:=25)
Tb.Name = "Delete_" & oShape.Name
Tb.Fill.ForeColor.RGB = RGB(255, 255, 0)
Tb.TextFrame.TextRange.Text = "Updated New link: " & NewAddress
' NewAddress is not defined
Tb.TextFrame.TextRange.Font.Size = 8
End If
End If
Next oShape
Next oSlide
CleanUp:
' Ensure Excel is closed if we created a new instance
If excelApp Is Nothing Then
' Do nothing as we didn't create it
Else
' Check if any workbooks are still open
If excelApp.Workbooks.Count = 0 Then
excelApp.Quit
End If
End If
Set excelApp = Nothing
' Release the object variable
ErrorHandler: MsgBox "Finish!"
End Sub

[yurble_vn]

Thanks Aussiebear,

I modified my code as following.
- I have to add in one fake step "Select Slide" when move to next slide. This fixed the issue on "VBA stop editing Embedded chart from 2nd slide onward".
- This code works fine except one thing: I have to open an Excel sheet in advance to make this code works. It seems the Open New Excel Instance did not work.

I did test this code without the that fake step of "select slide", it does not work.



Sub Chart___Testing()
Dim oPres As Presentation
Dim oSlide As Slide
Dim oShape As Shape
Dim myChart As PowerPoint.Chart
Dim Wb As Object
Dim excelApp As Object
Dim answer As Integer
Dim ExecFlag As Boolean

'Reconfirm before Execute
answer = MsgBox("This macro will update linked data in all charts, and embedded Excels." _
& vbCrLf & "And update dyanmic tables that named 'Data'/'Table1' in 'Data'/'Sheet1' Sheets." _
& vbCrLf & "DOES NOT WORK ON GROUPED CHARTS" & vbCrLf & "BACKUP FILE BEFORE RUNNING." & vbCrLf & "Continue?" _
, vbQuestion + vbYesNo + vbDefaultButton2, "WARNING")

If answer = vbNo Then
GoTo ErrorHandler
End If

ExecFlag = False

' Get the active presentation
Set oPres = ActivePresentation

' Attempt to get an existing Excel instance, or create a new one if none exists
On Error Resume Next
Set excelApp = GetObject(, "Excel.Application")
On Error GoTo 0
If excelApp Is Nothing Then
Set excelApp = CreateObject("Excel.Application")
End If
' Keep Excel hidden unless explicitly needed for user interaction
excelApp.Visible = False
excelApp.DisplayAlerts = False
' To prevent prompts

' Loop through each slide
For Each oSlide In oPres.Slides
oSlide.Select
' Loop through each shape on the slide

For Each oShape In oSlide.Shapes

'Update PowerPointChart
If oShape.HasChart Then
Set myChart = oShape.Chart
myChart.ChartData.Activate
ExecFlag = True

Else
If oShape.Type = msoEmbeddedOLEObject Then
Set Wb = oShape.OLEFormat.Object
On Error Resume Next
'Check if the OLE object is an Excel Workbook
If TypeName(Wb) = "Workbook" Then
oShape.OLEFormat.Activate
ExecFlag = True
End If
End If
End If
If ExecFlag Then
' Set the active workbook
Set Wb = excelApp.ActiveWorkbook
On Error Resume Next
'Update Link
Wb.UpdateLink Name:=Wb.LinkSources
On Error GoTo 0
'Change Cell BZ1 value
Wb.Worksheets("Data").Range("BZ1").Value = "AABBDED"
'Search and Replace
Wb.Worksheets("Data").Range("A1:M50").Replace "Apple", "Banana"
'Update Filter table
On Error Resume Next
Wb.Worksheets("Data").ListObjects("Data").Range.AutoFilter Field:=1, Criteria1:="<>0"
On Error Resume Next
Wb.Worksheets("Sheet1").ListObjects("Data").Range.AutoFilter Field:=1, Criteria1:="<>0"
On Error Resume Next
Wb.Worksheets("Data").ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:="<>0"
On Error Resume Next
Wb.Worksheets("Sheet1").ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:="<>0"
'Refresh Screen and Close
Wb.RefreshAll
Wb.Close SaveChanges:=False ' Specify not to save changes

'Put A Updated Textbox
Dim Tb As Shape
Set Tb = oSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=oShape.Left, Top:=oShape.Top, Width:=100, Height:=25)
Tb.Name = "Delete_" & oShape.Name
Tb.Fill.ForeColor.RGB = RGB(255, 255, 0)
Tb.TextFrame.TextRange.Text = "Updated Data"
Tb.TextFrame.TextRange.Font.Size = 8
Tb.Select
'Turn off Execution Flag to check again next Shape
ExecFlag = False
End If

Next oShape
Next oSlide
CleanUp:
' Ensure Excel is closed if we created a new instance
excelApp.DisplayAlerts = True
If excelApp Is Nothing Then
' Do nothing as we didn't create it
Else
' Check if any workbooks are still open
If excelApp.Workbooks.Count = 0 Then
excelApp.Quit
End If
End If

Set excelApp = Nothing
' Release the object variable
ErrorHandler: MsgBox "Finish!"

End Sub

[Aussiebear]

Your code is considerably different

[Aussiebear]

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

[yurble_vn]

Thanks AussieBear

yes, it works perfectly. Just three small things:
- wsName, and loName have to be declared as 'Variant'
- oShape.OLEFormat.Activate can not be closed by wb.close , i have to change it back to Do.Verb.
- The Excel window still show up.


Sub Chart___Testing_Revised_V7()
' 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 Variant
Dim loName As Variant
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.DoVerb (2) '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

[Aussiebear]

Thank you for your feedback.

[Aussiebear]

Hmmm... does this fix your issue?



Sub Chart___Testing_Revised_V8()
' 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 Variant ' Changed to Variant as per user feedback
Dim loName As Variant ' Changed to Variant as per user feedback
Dim errNum As Long
' Constants
Const PROC_NAME As String = "Chart___Testing_Revised_V8" ' 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 = ActivePresentatio
' 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
' Changed back to DoVerb as per user feedback
oShape.OLEFormat.DoVerb 1 ' 1 is typically the "Open" verb
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 'Release
Set TempSheet = Nothing 'Release
' 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

[yurble_vn]

Hi AussieBear,

Many thank for your kind support...
but, V8 keep coming with Error: 424, Object Required (with or without Excel openning)...

V7 works fine for me..., i can stand with the Excel Window Pop Up...

regards
Yurble