Option Explicit

Const sQuellPfad As String = "E:\Temp\PP\PP_Dateien"
Const sZielDatei As String = "E:\Temp\PP\NeuePraes.ppt"

Dim ppZiel As Presentation

Sub PPTsKopierenInNeuePPT()
  Dim sDatei As String
  Dim iZaehler As Integer

  iZaehler = 0
  sDatei = Dir(sQuellPfad & "\" & "*.ppt")

  If sDatei <> "" Then
    iZaehler = 1
    Set ppZiel = Presentations.Add
    Call SlidesInsertFromFile(sQuellPfad & "\" & sDatei)
  End If

  Do While sDatei <> ""
    sDatei = Dir
    If sDatei <> "" Then
      iZaehler = iZaehler + 1
      Call SlidesInsertFromFile(sQuellPfad & "\" & sDatei)
    End If
  Loop

  If iZaehler = 0 Then
    MsgBox "Es sind keine Dateien mit Endung *.ppt " & _
        "im Verzeichnis" & vbCrLf & sQuellPfad & vbCrLf & _
        "vorhanden!!", vbOKOnly + vbInformation, _
        Title:="Folien in eine neue Präsentation kopieren"

  Else
    ppZiel.SaveAs sZielDatei
    ppZiel.Close
    Set ppZiel = Nothing
  End If
End Sub

Sub SlidesInsertFromFile(sQuellDatei As String)
  Dim iZielAnzSlides As Integer

  iZielAnzSlides = ppZiel.Slides.Count
  ppZiel.Slides.InsertFromFile sQuellDatei, iZielAnzSlides
End Sub