Powerpoint Dateien per Excel Makro zusammenfügen

Sub CreateNewPowerPointPresentation()
'(C) Ramses
'Import aus einer externen Powerpoint Präsentation spezifische
'Folien und speichert diese in der angegebenen Nummerierung in
'einer neuen Präsentation
'Die Tabelle muss in A1 der aktiven Tabelle den kompletten Pfad zur importierenden Prä _
sentation haben
'In der Spalte A werden die jeweiligen durch eine Zahl markierte Folie importiert
'Die Zahlen in der Spalte A geben die Anordnung der zu importierenden Folien an
'Die zu importierende Datei wird aus den Einträgen in der Spalte C und D gebildet
Dim myPP As Object, newTarPP As Object
Dim srcFile As String, newPPtar As String, newPPspec As String, tarPPPath As String
Dim i As Long
Dim startRow As Long, endRow As Long
Dim totSlides As Long, sinSlide As Long
'Anpassungen vornehmen
'Hier beginnen die Daten in der Tabelle
startRow = 4
'Ab hier keine Änderungen mehr vornehmen
On Error GoTo myErrorHandler
'Spezifischen Dateiname abfragen
newPPspec = InputBox("Geben Sie den Dateinamen an. " & vbCrLf & vbCrLf & _
"ACHTUNG: Keine Sonderzeichen wie ""/"", ""\"", "":"", "";"", ""@"" oder ähnliches  _
verwenden." & vbCrLf & vbCrLf & _
"Die Datei wird als Präfix das Datum im Format ""YYYY-MM-DD"" haben", "Dateiname definieren" _
_
_
_
_
, "Neue Präsentation")
If StrPtr(newPPspec) = 0 Then
MsgBox "Kein Dateinamen angegeben", vbCritical + vbOKOnly, "Fehler"
Exit Sub
End If
'Neues PP Object erstellen
Set myPP = CreateObject("Powerpoint.Application")
'Quellpäsentation definieren
srcFile = Range("a1").Text
'Zielpfad automatisch ermitteln
'Allenfalls auskommentieren mit Hochkomma
tarPPPath = Range("A1").Text
If Right(tarPPPath, 1)  "\" Then
tarPPPath = tarPPPath & "\"
End If
'Neuer Name für Präsentation definieren
newPPtar = Format(Date, "YYYY-MM-DD") & newPPspec & ".ppt"
'Neue Präsentation anlegen
Set newTarPP = myPP.presentations.Add
'Letzten Eintrag in Spalte a feststellen
endRow = Cells(Rows.Count, 1).End(xlUp).Row
'Anzahl Folien feststellen für die Import Informationen in der Statusbar
totSlides = Application.WorksheetFunction.Count(Range(Cells(startRow, 1), Cells(endRow, 1))) _
_
_
_
_
'SlideCounter definieren
sinSlide = 1
With newTarPP
'SlideImport starten
For i = startRow To endRow
If Cells(i, 1)  "" Then
'Dateinamen zusammensetzen
srcFile = tarPPPath & Cells(i, 3) & Cells(i, 4)
'Datei auf existenz prüfen
'Testen ob Datei vorhanden
If Dir(srcFile) = "" Then
MsgBox "Quelldatei: " & srcFile & " wurde nicht gefunden.", vbCritical +  _
vbOKOnly, "Fehler"
Exit Sub
End If
'Benutzerhinweis
Application.StatusBar = "Import Slide: " & sinSlide & " von " & totSlides & "    _
_
_
_
_
Folien"
'Folie/n importieren
'Importsyntax lautet:
'.Slides.InsertFromFile Dateiname, An welche Position, Folie Von, Folie Bis
'"An welche Position" bedeutet hier zunächst ans Ende setzen, also ".Slides. _
Count"
'.Slides.InsertFromFile srcFile, .Slides.Count, Cells(i, 1).Value, Cells(i, 1).  _
_
_
_
_
Value
'Die hier zu importierenden Präsentationen haben NUR 1 Folie
.Slides.InsertFromFile srcFile, .Slides.Count, 1, 1
'Slidecounter hochsetzen = Hilfsvariable für Statusbar-Anzeige
sinSlide = sinSlide + 1
End If
Next i
'Benutzerhinweis
Application.StatusBar = "Die Folien werden sortiert"
sinSlide = 1
For i = startRow To endRow
If Cells(i, 1)  "" Then
'Benutzerhinweis
Application.StatusBar = "Verschiebe Folie: " & sinSlide & " von " & totSlides &  _
_
_
_
_
" Folien"
.Slides(sinSlide).moveto topos:=Cells(i, 1).Value
sinSlide = sinSlide + 1
End If
Next i
.SaveAs tarPPPath & " " & newPPtar
End With
'Benutzerhinweis
MsgBox "Slideimport vollständig durchgeführt", vbInformation + vbOKOnly, "Abschluss"
'Ausstiegspunkt für den Fehlerhandler
ErrorExit:
'Statusbar zurücksetzen
Application.StatusBar = False
Exit Sub
myErrorHandler:
MsgBox "Folgender Fehler ist aufgetreten: " & vbCrLf & Err.Number & vbCrLf & vbCrLf & Err.   _
_
_
_
_
Description, vbOKOnly + vbCritical, "Fehler"
Resume ErrorExit
End Sub