从 Excel 更新 Powerpoint 时，object 个“_Application”的 'DisplayAlerts' 失败
'DisplayAlerts' of object '_Application' failed while updating Powerpoint from Excel
我正在尝试根据 Excel 2010 中存储的数据更新在 Powerpoint 2010 中创建的图表。
我使用 Insert Object 和 Create New Microsoft Excel Chart 在 Powerpoint 中创建了图表（然后您可以 right-click 图表和 select Edit Object 打开它的数据 sheet).
除一行外一切正常...
在代码的末尾，我 Application.DisplayAlerts = TRUE 在整理 ThisWorkbook（删除 sheet）后重新打开通知 - 我关闭通知如果我在删除 sheet.
之前执行此操作，则会抛出该过程的开始错误
这总是在问题标题中引发错误。 我认为它可能会混淆我指的是哪个应用程序 - Thisworkbook、Powerpoint 或 PPT 中使用的 Excel 实例图表。
我试过使用：ThisWorkbook.Application.DisplayAlerts = True & ThisWorkbook.Parent.DisplayAlerts = True 但没有成功。
有什么想法吗？
我的代码是：
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
从代码中调用的其他函数：
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
似乎这个问题的简单答案是（我几年前学到的东西，但是因为懒惰而咬了我）.... 将你的代码分成单独的程序以提高可读性并使在需要时更容易重置变量。
在我的原始代码中，演示文稿中的每张幻灯片都有完整的部分。我原来的代码 post 只显示了一张幻灯片的代码。
以这种方式编写代码导致了另一个问题 - 我的图表开始显示不正确的数据，我无法理解为什么 - 运行 整个代码都搞砸了，逐行执行它并且它起作用了。
我将每张幻灯片分成一个单独的程序来解决错误（它有效）并将 DisplayAlerts 放入主程序中，我不再收到错误消息。
Option Explicit
Private wrkShtDataFile As Worksheet 'Reference to raw data worksheet.
Private rDataFileLastCell As Range 'Reference to last cell on raw data worksheet.
Private sReportMonth As String 'Text displaying current month.
Private sReportYear As String 'Text displaying current year.
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 oPPT As Object 'Reference to PPT application.
Dim oPresentation As Object 'Reference to opened presentation.
Dim wrkBkDataFile As Workbook 'Reference to raw data XLSX file.
Dim oSlide As Object 'Reference to slide in PPT.
sTemplate = ThisWorkbook.Path & "\PPT Template\Zero Commission Template.pptx"
sDataFileFullName = GetFile(ThisWorkbook.Path)
sDataFileName = Mid(sDataFileFullName, InStrRev(sDataFileFullName, "\") + 1, Len(sDataFileFullName))
If sDataFileFullName <> "" Then
Application.DisplayAlerts = False
'Open the Powerpoint template and save a copy so we can roll back.
Set oPPT = CreatePPT
Set oPresentation = oPPT.Presentations.Open(sTemplate)
oPresentation.SaveCopyAs _
Left(oPresentation.FullName, InStrRev(oPresentation.FullName, ".") - 1) & " (Previous)"
Set wrkBkDataFile = Workbooks.Open(sDataFileFullName, UpdateLinks:=False)
Set wrkShtDataFile = wrkBkDataFile.Worksheets(1)
Set rDataFileLastCell = LastCell(wrkShtDataFile)
sReportMonth = Format(wrkShtDataFile.Range("AD2"), "mmmm")
sReportYear = Format(wrkShtDataFile.Range("AD2"), "yyyy")
'Add the month and year to the Title slide.
Set oSlide = oPresentation.slides(1)
With oSlide
.Shapes("Report_Date").TextFrame.TextRange.Text = sReportMonth & " " & sReportYear
End With
Set oSlide = Nothing
'Calls to update slides:
Audit_Volumes oPresentation.slides(2)
Monthly_Accuracy_Trends oPresentation.slides(3)
Monthly_Entry_Type oPresentation.slides(4)
Reporting_Reason oPresentation.slides(5)
Monthly_Team_Volumes oPresentation.slides(6)
NoErrorChart oPresentation.slides(9), "New"
NoErrorChart oPresentation.slides(12), "Mid-Term"
NoErrorChart oPresentation.slides(15), "Renewal"
ErrorTable oPresentation.slides(8), "New"
ErrorTable oPresentation.slides(11), "Mid-Term"
ErrorTable oPresentation.slides(14), "Renewal"
oPresentation.SaveAs ThisWorkbook.Path & "\Reports\Quality Review - Zero Comms Deck " & sReportMonth & " " & sReportYear
wrkBkDataFile.Close SaveChanges:=False
'This now works:
Application.DisplayAlerts = True
End If
End Sub
我正在尝试根据 Excel 2010 中存储的数据更新在 Powerpoint 2010 中创建的图表。
我使用 Insert Object 和 Create New Microsoft Excel Chart 在 Powerpoint 中创建了图表（然后您可以 right-click 图表和 select Edit Object 打开它的数据 sheet).
除一行外一切正常...
在代码的末尾，我 Application.DisplayAlerts = TRUE 在整理 ThisWorkbook（删除 sheet）后重新打开通知 - 我关闭通知如果我在删除 sheet.
之前执行此操作，则会抛出该过程的开始错误
这总是在问题标题中引发错误。 我认为它可能会混淆我指的是哪个应用程序 - Thisworkbook、Powerpoint 或 PPT 中使用的 Excel 实例图表。
我试过使用：ThisWorkbook.Application.DisplayAlerts = True & ThisWorkbook.Parent.DisplayAlerts = True 但没有成功。
有什么想法吗？
我的代码是：
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
从代码中调用的其他函数：
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
似乎这个问题的简单答案是（我几年前学到的东西，但是因为懒惰而咬了我）.... 将你的代码分成单独的程序以提高可读性并使在需要时更容易重置变量。
在我的原始代码中，演示文稿中的每张幻灯片都有完整的部分。我原来的代码 post 只显示了一张幻灯片的代码。
以这种方式编写代码导致了另一个问题 - 我的图表开始显示不正确的数据，我无法理解为什么 - 运行 整个代码都搞砸了，逐行执行它并且它起作用了。
我将每张幻灯片分成一个单独的程序来解决错误（它有效）并将 DisplayAlerts 放入主程序中，我不再收到错误消息。
Option Explicit
Private wrkShtDataFile As Worksheet 'Reference to raw data worksheet.
Private rDataFileLastCell As Range 'Reference to last cell on raw data worksheet.
Private sReportMonth As String 'Text displaying current month.
Private sReportYear As String 'Text displaying current year.
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 oPPT As Object 'Reference to PPT application.
Dim oPresentation As Object 'Reference to opened presentation.
Dim wrkBkDataFile As Workbook 'Reference to raw data XLSX file.
Dim oSlide As Object 'Reference to slide in PPT.
sTemplate = ThisWorkbook.Path & "\PPT Template\Zero Commission Template.pptx"
sDataFileFullName = GetFile(ThisWorkbook.Path)
sDataFileName = Mid(sDataFileFullName, InStrRev(sDataFileFullName, "\") + 1, Len(sDataFileFullName))
If sDataFileFullName <> "" Then
Application.DisplayAlerts = False
'Open the Powerpoint template and save a copy so we can roll back.
Set oPPT = CreatePPT
Set oPresentation = oPPT.Presentations.Open(sTemplate)
oPresentation.SaveCopyAs _
Left(oPresentation.FullName, InStrRev(oPresentation.FullName, ".") - 1) & " (Previous)"
Set wrkBkDataFile = Workbooks.Open(sDataFileFullName, UpdateLinks:=False)
Set wrkShtDataFile = wrkBkDataFile.Worksheets(1)
Set rDataFileLastCell = LastCell(wrkShtDataFile)
sReportMonth = Format(wrkShtDataFile.Range("AD2"), "mmmm")
sReportYear = Format(wrkShtDataFile.Range("AD2"), "yyyy")
'Add the month and year to the Title slide.
Set oSlide = oPresentation.slides(1)
With oSlide
.Shapes("Report_Date").TextFrame.TextRange.Text = sReportMonth & " " & sReportYear
End With
Set oSlide = Nothing
'Calls to update slides:
Audit_Volumes oPresentation.slides(2)
Monthly_Accuracy_Trends oPresentation.slides(3)
Monthly_Entry_Type oPresentation.slides(4)
Reporting_Reason oPresentation.slides(5)
Monthly_Team_Volumes oPresentation.slides(6)
NoErrorChart oPresentation.slides(9), "New"
NoErrorChart oPresentation.slides(12), "Mid-Term"
NoErrorChart oPresentation.slides(15), "Renewal"
ErrorTable oPresentation.slides(8), "New"
ErrorTable oPresentation.slides(11), "Mid-Term"
ErrorTable oPresentation.slides(14), "Renewal"
oPresentation.SaveAs ThisWorkbook.Path & "\Reports\Quality Review - Zero Comms Deck " & sReportMonth & " " & sReportYear
wrkBkDataFile.Close SaveChanges:=False
'This now works:
Application.DisplayAlerts = True
End If
End Sub