我尝试从存储在Excel 2010中的数据更新在Powerpoint 2010中创建的图表
我使用Insert Object和Create New Microsoft Excel Chart在Powerpoint中创建了图表（然后您可以右键单击图表并选择Edit Object打开其数据表）。
除了一行之外，一切都很完美......
在代码的最后，我Application.DisplayAlerts = TRUE在我整理ThisWorkbook（删除工作表）后重新启用通知 - 我在开始时关闭通知如果我在删除工作表之前执行此操作，则会抛出错误的程序
这总是在问题标题中引发错误。我认为我可能会对我的意思是哪个应用程序感到困惑 - 本工作簿，Powerpoint或PPT图表中使用的Excel实例。
我尝试过使用：ThisWorkbook.Application.DisplayAlerts = True＆amp; 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
答案 0 :(得分：0)
似乎问题的简单答案是（我多年前学过的东西，但是很懒，而且让我感到困惑）.... 将代码拆分为单独的程序以提高可读性并使其更容易重置你需要的变量。
在我的原始代码中，我在演示文稿中为每张幻灯片提供了整个部分。我原始帖子中的代码只显示了一张幻灯片的代码 以这种方式编写代码会导致另一个问题 - 我的图表开始显示不正确的数据，我无法理解为什么 - 运行整个代码并且它变得混乱，逐行逐步执行它并且工作正常。
我将每个幻灯片拆分为一个单独的过程来解决错误（它有效）并将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