PowerPoint Titel und Untertitel - Liste in Excel...

Frage: In Excel habe ich eine Liste von Überschriften und Untertiteln (Spalte A und B). Diese sollen jede Zeile in eine neue PowerPoint Folie in "Title" und "Subtitle". Es sind also bei 100 Zeilen in Exxel 100 neue PowerPoint Folien mit den entsprechenden Texten. Wie geht das?

In Excel I have a list of headlines and captions (column A and B). These should each row in a new PowerPoint slide in the "Title" and "Subtitle". So there are 100 rows in Exxel 100 new PowerPoint slides with the corresponding texts. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
PowerPoint Titel und Untertitel - Liste in Excel...[XLS 70 KB]

OptionExplicit
' Slide mit Titel in PowerPoint 
' Liste der möglichen Konstanten folgt unten 
Const ppLayoutTitle = 1
' Objektvariable für Applikation 
Dim objPP AsObject
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 12.03.2013 
' Purpose   : PowerPoint - new Presentation - slide add - list in Excel... 
'-------------------------------------------------------------------------- 
PublicSub Main()
    ' Variablendeklaration 
    Dim objPPSlide AsObject
    Dim objPPNewP AsObject
    Dim lngLastRow AsLong
    Dim lngCalc AsLong
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    OnErrorGoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten 
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen 
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert 
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung 
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell" 
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken 
        .DisplayAlerts = False
    EndWith
    ' PowerPoint starten 
    ' Wenn PowerPoint ausgeblendet werden soll, dann so: 
    ' Funktioniert nicht in Version 2003. Getestet in 2007 und 2010 
    ' http://vbanet.blogspot.de/2010/09/excel-powerpoint.html 
    Set objPP = OffApp("PowerPoint")
    IfNot objPP IsNothingThen
        ' Letzte Zeile in Worksheet "Sheet1" in Spalte A, 
        ' also gegebenenfalls anpassen!! 
        With ThisWorkbook.Worksheets("Sheet1")
            lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
                .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row)
        EndWith
        With objPP
            ' Neue Präsentation 
            Set objPPNewP = .Presentations.Add
            ' Vom Ende in Spalte A bis Zeile 2 in Excel 
            For lngLastRow = lngLastRow To2Step -1
            ' Neues Slide an Objektvariable übergeben 
                Set objPPSlide = .ActivePresentation.Slides.Add _
                    (1, ppLayoutTitle)
                With objPPSlide
                    ' Text in Überschrift reinschreiben und Größe zuordnen 
                    With .Shapes(1).TextFrame.TextRange
                        .Text = ThisWorkbook.Worksheets _
                            ("Sheet1").Cells(lngLastRow, 1).Value
                        .Font.Size = 50
                    EndWith
                    ' Text in Untertitel reinschreiben und Größe zuordnen 
                    With .Shapes(2).TextFrame.TextRange
                        .Text = ThisWorkbook.Worksheets _
                            ("Sheet1").Cells(lngLastRow, 2).Value
                        .Font.Size = 25
                    EndWith
                EndWith
            Next lngLastRow
        EndWith
    Else
        MsgBox "Application not installed!"
    EndIf
Fin:
    ' Objektvariablen zurücksetzen 
    Set objPPNewP = Nothing
    Set objPPSlide = Nothing
    Set objPP = Nothing
    ' Die Applikation aufwecken 
    With Application
        ' Bildschirmaktualisierung wieder einschalten 
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert 
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert 
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen 
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens 
        .CutCopyMode = True
    EndWith
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0Then MsgBox "Error: "& _
        Err.Number &" "& Err.Description
EndSub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : OffApp 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 12.03.2013 
' Purpose   : Start application... 
'-------------------------------------------------------------------------- 
PrivateFunction OffApp(ByVal strApp AsString, _
    Optional blnVisible AsBoolean = True) AsObject
    OnErrorResumeNext
    Set objPP = GetObject(, strApp &".Application")
    SelectCase Err.Number
        Case429
            Err.Clear
            Set objPP = CreateObject(strApp &".Application")
            If blnVisible = TrueThen
                OnErrorResumeNext
                objPP.Visible = True
                Err.Clear
            EndIf
    EndSelect
    OnErrorGoTo 0
    Set OffApp = objPP
    Set objPP = Nothing
EndFunction

' List of constants for the insert slide in PowerPoint 
' Liste der Konstanten für die einzufügende Folie in PowerPoint 

' Const ppLayoutBlank = 12 
' Const ppLayoutChart = 8 
' Const ppLayoutChartAndText = 6 
' Const ppLayoutClipartAndText = 10 
' Const ppLayoutClipArtAndVerticalText = 26 
' Const ppLayoutComparison = 34 
' Const ppLayoutContentWithCaption = 35 
' Const ppLayoutCustom = 32 
' Const ppLayoutFourObjects = 24 
' Const ppLayoutLargeObject = 15 
' Const ppLayoutMediaClipAndText = 18 
' Const ppLayoutMixed = -2 
' Const ppLayoutObject = 16 
' Const ppLayoutObjectAndText = 14 
' Const ppLayoutObjectAndTwoObjects = 30 
' Const ppLayoutObjectOverText = 19 
' Const ppLayoutOrgchart = 7 
' Const ppLayoutPictureWithCaption = 36 
' Const ppLayoutSectionHeader = 33 
' Const ppLayoutTable = 4 
' Const ppLayoutText = 2 
' Const ppLayoutTextAndChart = 5 
' Const ppLayoutTextAndClipart = 9 
' Const ppLayoutTextAndMediaClip = 17 
' Const ppLayoutTextAndObject = 13 
' Const ppLayoutTextAndTwoObjects = 21 
' Const ppLayoutTextOverObject = 20 
' Const ppLayoutTitle = 1 ' Das habe ich oben verwendet!!! 
' Const ppLayoutTitleOnly = 11 
' Const ppLayoutTwoColumnText = 3 
' Const ppLayoutTwoObjects = 29 
' Const ppLayoutTwoObjectsAndObject = 31 
' Const ppLayoutTwoObjectsAndText = 22 
' Const ppLayoutTwoObjectsOverText = 23 
' Const ppLayoutVerticalText = 25 
' Const ppLayoutVerticalTitleAndText = 27 
' Const ppLayoutVerticalTitleAndTextOverChart = 28