« DisplayAlerts » de l'objet « _Application » a échoué lors de la mise à jour à partir d'Excel Powerpoint

Question

Je suis en train de mettre à jour les cartes créées dans PowerPoint 2010 à partir des données stockées dans Excel 2010.
J'ai créé les graphiques dans Powerpoint en utilisant Insert Object et Create New Microsoft Excel Chart (vous pouvez ensuite cliquer avec le bouton droit sur le graphique et sélectionner Edit Object pour ouvrir sa fiche technique).

Tout fonctionne parfaitement, sauf une ligne ...

A la fin du code je Application.DisplayAlerts = TRUE pour désactiver les notifications dos après que je l'ai rangé ThisWorkbook (suppression d'une feuille) - Je tourne les notifications arrêt le début de la procédure comme une erreur est levée si je le fais juste avant de supprimer la feuille.
Ceci lance toujours l'erreur dans le titre de la question. Je pensais qu'il pourrait être confus sur quelle application je veux dire - Thisworkbook, Powerpoint ou l'instance d'Excel utilisée dans le tableau PPT. J'ai essayé d'utiliser: ThisWorkbook.Application.DisplayAlerts = True & ThisWorkbook.Parent.DisplayAlerts = True mais sans chance.

Des idées?

Mon code est:

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 

Autres fonctions appelées à partir du 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 

Answer 1

Il semble que la réponse simple à la question est (quelque chose que j'ai appris il y a des années, mais était paresseux et il m'a mordu) .... divisez votre code en procédures distinctes pour plus de lisibilité et pour faciliter la réinitialisation de vos variables si nécessaire.

Dans mon code d'origine, j'avais des sections entières pour chaque diapositive de la présentation. Le code dans mon post original montre juste le code pour une glissière.
L'écriture du code de cette manière a causé un autre problème - mes graphiques ont commencé à afficher des données incorrectes et je n'ai pas pu comprendre pourquoi - exécuter tout le code et le dégrossir, le parcourir ligne par ligne et cela a fonctionné.

Je divise chaque diapositive en une procédure distincte pour résoudre l'erreur (cela a fonctionné) et mettre le DisplayAlerts dans la procédure principale et je ne reçois plus le message d'erreur.

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