Excel VBAでPPTファイルをコピーできない

Question

次のコードがありますが、Excelでリストをループしてリスト内の各pptファイルを開き、新しいpptファイルにコピーするように修正しようとしました。しかし、ハングアップしてループ中にエラーが発生しています。

Sub tmp() 
'Set a VBE reference to Microsoft PowerPoint Object Library 
    On Error GoTo ErrorHandler 
    Dim PPApp As PowerPoint.Application 
    Dim i, j As Integer 
    Dim pres1, new_pres As PowerPoint.Presentation 
    Dim oslide, s, oSld As PowerPoint.Slide 
    Dim oShape, oSh, oshp As PowerPoint.Shape 

    Dim wb As Workbook 
    Dim list As Worksheet 

    Set PPApp = CreateObject("Powerpoint.Application") 
    PPApp.Visible = True 
    Set new_pres = PPApp.Presentations.Add 
    Set wb = ThisWorkbook 
    Set list = wb.Worksheets("Powerpoint File List") 
    LastRow = list.Range("A" & Rows.Count).End(xlUp).Row 
    new_pres.PageSetup.SlideSize = ppSlideSizeOnScreen 


       ' this is not working 
     For i = 1 To 1 ' LastRow 
      filepath = list.Range("A" & i).Value 
      Set pres1 = PPApp.Presentations.Open(filepath) 
      For j = 1 To pres1.Slides.Count 
       pres1.Slides.shapes(j).Copy 
       new_pres.Slides.Paste 
       new_pres.Application.CommandBars.ExecuteMso "PasteSourceFormatting") 

      Next j 
      pres1.Close 
      Set pres1 = Nothing 
     Next I 

NormalExit: 
Exit Sub 
ErrorHandler: 
Call MsgBox("Error:" & vbCrLf & Err.Number & vbCrLf & Err.Description, _ 
vbOKOnly, "Error inserting files") 
Resume NormalExit 

End Sub 

Answer 1

私はそれがExcelに変換するときに必要ではなかったPowerpointから実行するときに必要だったPasteSourceFormattingでした。これにより、リストからすべてのファイルが取り出され、開いて、フォーマットされたマスターパワーポイントにコピーされ、閉じます。最後に、私は、エラーがあると、それが発生した行に何を含めるようにしてくださいリスト

Sub tmp() 
'Set a VBE reference to Microsoft PowerPoint Object Library 
Application.CutCopyMode = False 
    On Error GoTo ErrorHandler 

    Dim PPApp As PowerPoint.Application 
    Dim i As Integer, j As Integer 
    Dim pres1 As PowerPoint.Presentation, new_pres As PowerPoint.Presentation 
    Dim oslide As PowerPoint.Slide, s As PowerPoint.Slide, oSld As PowerPoint.Slide 
    Dim oShape As PowerPoint.Shape, oSh As PowerPoint.Shape, oshp As PowerPoint.Shape 
    Dim PPShape As Object 


    Dim wb As Workbook 
    Dim list As Worksheet 

    Set PPApp = CreateObject("Powerpoint.Application") 
    PPApp.Visible = True 
    Set new_pres = PPApp.Presentations.Add 
    Set wb = ThisWorkbook 
    Set list = wb.Worksheets("Powerpoint File List") 
    LastRow = list.Range("A" & Rows.Count).End(xlUp).Row 
    new_pres.PageSetup.SlideSize = ppSlideSizeOnScreen 


       ' this is not working 

     k = 1 
     For i = 1 To LastRow 
      filepath = list.Range("A" & i).Value 
      Set pres1 = PPApp.Presentations.Open(filepath) 

      For j = 1 To pres1.Slides.Count 
        pres1.Slides(j).Copy 


       new_pres.Slides.Paste 
       ' new_pres.Slides.Paste 

       ' new_pres.Application.CommandBars.ExecuteMso ("PasteSourceFormatting") 
       k = k + 1 
      Next j 

      pres1.Close 


      Set pres1 = Nothing 

     Next i 

     For Each oSld In new_pres.Slides 
      oSld.HeadersFooters.Clear 
      oSld.HeadersFooters.SlideNumber.Visible = msoFalse 
      oSld.HeadersFooters.DateAndTime.Visible = msoFalse 
     Next oSld 

     With new_pres.SlideMaster.Shapes 
      Set oshp = .AddTextbox(msoTextOrientationHorizontal, 700, 520, 100, 50) 
      oshp.TextFrame.TextRange.Font.Name = "Arial" 
      oshp.TextFrame.TextRange.Font.Size = 7 
      oshp.TextFrame.TextRange.InsertSlideNumber 
     End With 
     'ActivePresentation.PageSetup.FirstSlideNumber = 0 
     new_pres.Slides(1).DisplayMasterShapes = msoTrue 

     Set oshp = Nothing 

     response = MsgBox(prompt:="Is this For Official Use Only?", Buttons:=vbYesNo) 
     If response = vbYes Then 
      txt = "For Official Use Only" 
      ' If statement to check if the yes button was selected. 
     Else 
     ' The no button was selected. 
      MsgBox "Then it is assumed this is a Boeing Proprietary presentation" 
      txt = "Boeing Proprietary" 
     End If 
     With new_pres.SlideMaster.Shapes 
      Set oshp = .AddTextbox(msoTextOrientationHorizontal, 300, 520, 100, 50) 
      oshp.TextFrame.TextRange.Font.Name = "Arial" 
      oshp.TextFrame.TextRange.Font.Size = 7 
      oshp.TextFrame.TextRange.Text = txt 
     End With 

     injdate = InputBox("Please enter the date for the Stand Up") 

     With new_pres.SlideMaster.Shapes 
      Set oshp = .AddTextbox(msoTextOrientationHorizontal, 10, 520, 100, 50) 
      oshp.TextFrame.TextRange.Font.Name = "Arial" 
      oshp.TextFrame.TextRange.Font.Size = 7 
      oshp.TextFrame.TextRange.Text = injdate 
     End With 






    Application.CutCopyMode = True 
NormalExit: 
Exit Sub 
ErrorHandler: 
Call MsgBox("Error:" & vbCrLf & Err.Number & vbCrLf & Err.Description, _ 
vbOKOnly, "Error inserting files") 
Resume NormalExit 

End Sub