I'm trying to update charts created in Powerpoint 2010 from data stored in Excel 2010.
I've created the charts in Powerpoint using Insert Object and Create New Microsoft Excel Chart(you can then right-click the chart and select Edit Object to open its data sheet).
Everything works perfectly except one line...
At the end of the code I have Application.DisplayAlerts = TRUE to turn notifications back on after I've tidied up ThisWorkbook (deleting a sheet) - I turn the notifications off at the start of the procedure as an error is thrown if I do it just before deleting the sheet.
This is always throwing the error in the question title. I thought it could be getting confused over which application I mean - Thisworkbook, Powerpoint or the instance of Excel used in the PPT chart.
I've tried using: ThisWorkbook.Application.DisplayAlerts = True & ThisWorkbook.Parent.DisplayAlerts = True but with no luck.
Any ideas?
My code is:
Option Explicit
Public Sub Produce_Report()
Dim sTemplate As String 'Path to PPTX Template.
Dim sDataFileFullName As String 'Path to raw data XLSX file.
Dim sDataFileName As String 'The file name without the path.
Dim wrkBkDataFile As Workbook 'Reference to raw data XLSX file.
Dim sSheetName As String 'Name of the first sheet in the workbook.
Dim rDataFileLastCell As Range 'Reference to last cell containing data in raw data.
Dim WrkSht As Worksheet 'Reference to worksheet in PPTX.
Dim WrkCht As Chart 'Reference to chart sheet in PPTX.
Dim oPPT As Object 'Reference to PPT application.
Dim oPresentation As Object 'Reference to opened presentation.
Dim oSlide As Object 'Reference to slide in PPT.
Dim oShape As Object 'Reference to text box in PPT.
Dim sReportMonth As String 'Text displaying current month.
Dim sReportYear As String 'Text displaying current year.
Dim rTemp As Range 'Temporary range object.
Dim rTemp2 As Range 'Temporary range object.
Dim WrkSht1 As Worksheet 'Temporary worksheet object.
Dim WrkSht2 As Worksheet 'Temporary worksheet object.
sTemplate = ThisWorkbook.Path & "\PPT Template\My Template.pptx"
sDataFileFullName = GetFile(ThisWorkbook.Path)
sDataFileName = Mid(sDataFileFullName, InStrRev(sDataFileFullName, "\") + 1, Len(sDataFileFullName))
'TODO: Check integrity of sDataFileFullName.
If sDataFileFullName <> "" Then
Application.DisplayAlerts = False
Set oPPT = CreatePPT
'Open the required files.
Set oPresentation = oPPT.Presentations.Open(sTemplate)
Set wrkBkDataFile = Workbooks.Open(sDataFileFullName, UpdateLinks:=False)
'TODO: Make the worksheet selection more intelligent.
sSheetName = wrkBkDataFile.Worksheets(1).Name
Set rDataFileLastCell = LastCell(wrkBkDataFile.Worksheets(sSheetName))
'Get the month and year from the 'Date_Audited' column.
sReportMonth = Format(wrkBkDataFile.Worksheets(1).Range("AD2"), "mmmm")
sReportYear = Format(wrkBkDataFile.Worksheets(1).Range("AD2"), "yyyy")
'''''''''''''''''''''''
'MONTHLY TEAM VOLUMES '
'''''''''''''''''''''''
Set oSlide = oPresentation.slides(6)
With oSlide
With .Shapes("chtReportingReason")
Set WrkSht = .OLEFormat.Object.Worksheets(1)
Set WrkCht = .OLEFormat.Object.Charts(1)
End With
Set WrkSht1 = ThisWorkbook.Worksheets.Add
'Copy data from raw data to the temp sheet.
With wrkBkDataFile.Worksheets(sSheetName)
.Range(.Cells(1, 28), .Cells(rDataFileLastCell.Row, 28)).Copy Destination:= _
WrkSht1.Cells(1, 1)
End With
With WrkSht1
'Remove duplicates and sort the data fields.
.Range(.Cells(1, 1), .Cells(LastCell(WrkSht1).Row, 1)).RemoveDuplicates _
Columns:=1, Header:=xlYes
Set rTemp2 = LastCell(WrkSht1)
With .Sort
.SortFields.Clear
.SortFields.Add Key:=WrkSht1.Range(WrkSht1.Cells(2, 1), WrkSht1.Cells(rTemp2.Row, 1)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange WrkSht1.Range(WrkSht1.Cells(2, 1), WrkSht1.Cells(rTemp2.Row, 1))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Add formula to count total entries and total breaches.
.Range("A1:D1") = Array("", "Total Volume", "Error Volume", "Accurate")
.Range(.Cells(2, 2), .Cells(rTemp2.Row, 2)).FormulaR1C1 = _
"=COUNTIF('[" & wrkBkDataFile.Name & "]" & sSheetName & "'!R1C28:R" & rDataFileLastCell.Row & "C28,RC1)"
.Range(.Cells(2, 3), .Cells(rTemp2.Row, 3)).FormulaR1C1 = _
"=COUNTIFS('[" & wrkBkDataFile.Name & "]" & sSheetName & "'!R1C28:R" & rDataFileLastCell.Row & "C28,RC1," & _
"'[" & wrkBkDataFile.Name & "]" & sSheetName & "'!R1C26:R" & rDataFileLastCell.Row & "C26,TRUE)"
.Range(.Cells(2, 4), .Cells(rTemp2.Row, 4)).FormulaR1C1 = _
"=COUNTIFS('[" & wrkBkDataFile.Name & "]" & sSheetName & "'!R1C28:R" & rDataFileLastCell.Row & "C28,RC1," & _
"'[" & wrkBkDataFile.Name & "]" & sSheetName & "'!R1C26:R" & rDataFileLastCell.Row & "C26,FALSE)"
.Range(.Cells(2, 2), .Cells(rTemp2.Row, 4)).Value = .Range(.Cells(2, 2), .Cells(rTemp2.Row, 4)).Value
'Empty the destination sheet of data and paste the new data in.
WrkSht.Cells.ClearContents
.Range(.Cells(1, 1), .Cells(rTemp2.Row, 4)).Copy Destination:=WrkSht.Range("A1")
End With
With WrkSht
WrkCht.SetSourceData .Range(.Cells(1, 1), .Cells(rTemp2.Row, 4))
oPPT.ActiveWindow.viewtype = 7
RefreshChart oPPT, oSlide.slidenumber, oSlide.Shapes("chtReportingReason")
End With
WrkSht1.Delete
Set WrkSht1 = Nothing
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'ERROR HAPPENS EVERY TIME HERE. '
'WILL CONTINUE WITHOUT PROBLEMS IF I PRESS F5 OR F8. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''
ThisWorkbook.Parent.DisplayAlerts = True
End If
End Sub
Other functions called from the code:
Public Function CreatePPT(Optional bVisible As Boolean = True) As Object
Dim oTmpPPT As Object
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Defer error trapping in case Powerpoint is not running. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
Set oTmpPPT = GetObject(, "Powerpoint.Application")
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If an error occurs then create an instance of Powerpoint. '
'Reinstate error handling. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Err.Number <> 0 Then
Err.Clear
On Error GoTo ERROR_HANDLER
Set oTmpPPT = CreateObject("Powerpoint.Application")
End If
oTmpPPT.Visible = bVisible
Set CreatePPT = oTmpPPT
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure CreatePPT."
Err.Clear
End Select
End Function
Public Function LastCell(WrkSht As Worksheet, Optional Col As Long = 0) As Range
Dim lLastCol As Long, lLastRow As Long
On Error Resume Next
With WrkSht
If Col = 0 Then
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
Else
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
End If
If lLastCol = 0 Then lLastCol = 1
If lLastRow = 0 Then lLastRow = 1
Set LastCell = WrkSht.Cells(lLastRow, lLastCol)
End With
On Error GoTo 0
End Function
Function GetFile(Optional startFolder As Variant = -1) As Variant
Dim fle As FileDialog
Dim vItem As Variant
Set fle = Application.FileDialog(msoFileDialogFilePicker)
With fle
.Title = "Select a File"
.AllowMultiSelect = False
.Filters.Add "Excel Files", "*.xls*", 1
If startFolder = -1 Then
.InitialFileName = Application.DefaultFilePath
Else
If Right(startFolder, 1) <> "\" Then
.InitialFileName = startFolder & "\"
Else
.InitialFileName = startFolder
End If
End If
If .Show <> -1 Then GoTo NextCode
vItem = .SelectedItems(1)
End With
NextCode:
GetFile = vItem
Set fle = Nothing
End Function
Public Sub RefreshChart(oPPT As Object, SlideNum As Long, sh As Object)
oPPT.ActiveWindow.viewtype = 7
oPPT.ActiveWindow.View.GoToSlide SlideNum
oPPT.ActiveWindow.viewtype = 9
sh.OLEFormat.DoVerb (1)
End Sub
ThisWorkbook.Parent.DisplayAlerts = Truedo you get the same error if it's literallyApplication.DisplayAlerts = True? – CominternApplication.DisplayAlerts = True,ThisWorkbook.Application.DisplayAlerts = True,ThisWorkbook.Parent.DisplayAlerts = Trueand I'm sure I tried a couple of others but can't think what the syntax would have been. There's a=FALSEline at the start which works, but if I move it to just before I delete the sheet at the bottom it also fails. – Darren Bartrup-Cook