VBA code to copy from 50 Excel to 50 ppts and save them

[SagarShreya]

Hi Team,
I am getting the error as "Runtime error of 438 object doesnt support this property or method" in the below code, the below code should copy from 50 excel to 50 ppt and close the excel and ppt and move to the next one each time . in loop until it is done for 50

Sub LoopAllExcelFilesInFolder()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*.xls*"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(Filename:=myPath & myFile)
    
    'Ensure Workbook has opened before moving on to next line of code
      DoEvents
    
    'Change First Worksheet's Background Fill Blue
      Dim rng As Range
Dim rng1 As Range
Dim rng2 As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object

Worksheets(1).Activate
  Set rng = ThisWorkbook.ActiveSheet.Range("C3:E11")
  Set rng1 = ThisWorkbook.ActiveSheet.Range("H3:J11")
  Set rng2 = ThisWorkbook.ActiveSheet.Range("C15:E23")
  ActiveSheet.Next.Activate
  Set rng3 = ThisWorkbook.ActiveSheet.Range("B2:K9")
  Set rng4 = ThisWorkbook.ActiveSheet.Range("B11:K19")
  SaveText = ThisWorkbook.ActiveSheet.Range("A1:A1")
  MsgBox SaveText
 
'Create an Instance of PowerPoint
  On Error Resume Next
    
    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    
    'Clear the error between errors
      Err.Clear

    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If

  On Error GoTo 0

'Optimize Code
  Application.ScreenUpdating = False
  
'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add

'Add a slide to the Presentation
  Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly

'Copy Excel Range
  rng.Copy
  
'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  
    'Set position:
      myShape.Left = 150
      myShape.Top = 252

'Second Table copy
rng1.Copy
'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  
    'Set position:
      myShape.Left = 66
      myShape.Top = 152
  
  'Third table copy
  rng2.Copy

'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

  'Set position:
      myShape.Left = 366
      myShape.Top = 352
   'Fourth table copy
  rng3.Copy

Set mySlide = myPresentation.Slides.Add(2, 11) '11 = ppLayoutTitleOnly
'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

  'Set position:
      myShape.Left = 366
      myShape.Top = 352
     
     'Fifth table copy
  rng4.Copy

'Set mySlide = myPresentation.Slides.Add(2, 11) '11 = ppLayoutTitleOnly
'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

  'Set position:
      myShape.Left = 366
      myShape.Top = 352

'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  'PowerPointApp.Activate
  MsgBox "Activate"
  'PowerPointApp.ActivePresentation.SaveAs "C:\Users\admin\Downloads\Save\" & SaveText & ".ppt"
'PowerPointApp.ActivePresentation.SaveAs "C:\Users\admin\Downloads\Save\1.ppt"
'MsgBox " Saved PPT with " & SaveText, vbInformation

  'MsgBox " Presentation is saved by" + SaveText
  
  'PowerPointApp.ActivePresentation.Close
   'Application.Presentations.("C:\Users\admin\Downloads\Save\" & SaveText & ".ppt").Close
   Application.ActivePresentation.SaveAs "C:\Users\admin\Downloads\Save\" & SaveText & ".ppt"
   
  'PowerPointApp.SaveCopyAs "C:\Users\admin\Downloads\Save\1.ppt"
  'PowerPointApp.SaveAs SaveText
 ' ActiveWorkbook.Close SaveChanges:=False
 ' ActivePresentation.SaveCopyAs "C:\Users\admin\Downloads\Save\1.ppt"
'Application.ActivePresentation.SaveCopyAs "C:\Users\admin\Downloads\Save\1.ppt", ppSaveAsPowerPoint4

'Clear The Clipboard
  Application.CutCopyMode = False
 'Next i

'Save and Close Workbook
      wb.Close SaveChanges:=True
      
    'Ensure Workbook has closed before moving on to next line of code
      DoEvents

    'Get next file name
      myFile = Dir
  Loop

'Message Box when tasks are completed
  MsgBox "Task Complete!"

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Please suggest me the solution

[SamT]

Just where in the code are you getting the error?

Application.ActivePresentation.SaveAs
Application is the Excel Application

Use PowerPointApp.ActivePresentation.SaveAs

[SagarShreya]

Just where in the code are you getting the error?

Application.ActivePresentation.SaveAs
Application is the Excel Application

Use PowerPointApp.ActivePresentation.SaveAs

Thanks for the solution, but now my code is not picking up the excel files from the specified folder but the execel in which the macro is written. Please let me know further steps

[SamT]

You might try specifying Workbook "wb" in this snippet

Worksheets(1).Activate 
        Set rng = ThisWorkbook.ActiveSheet.Range("C3:E11") 
        Set rng1 = ThisWorkbook.ActiveSheet.Range("H3:J11") 
        Set rng2 = ThisWorkbook.ActiveSheet.Range("C15:E23") 
        ActiveSheet.Next.Activate 
        Set rng3 = ThisWorkbook.ActiveSheet.Range("B2:K9") 
        Set rng4 = ThisWorkbook.ActiveSheet.Range("B11:K19") 
        SaveText = ThisWorkbook.ActiveSheet.Range("A1:A1") 
        MsgBox SaveText

with wb
With .Worksheets(1)
        Set rng = .Range("C3:E11") 
        Set rng1 = .Range("H3:J11") 
        Set rng2 = .Range("C15:E23") 
End With
With .Worksheets(2)
         Set rng3 = .Range("B2:K9") 
        Set rng4 = .Range("B11:K19") 
        SaveText = .Range("A1:A1") 
        MsgBox SaveText 
End With
end with