PowerPoint Titel und Untertitel - Titel kein Zeilenumbruch...

Frage: Ich möchte Texte aus Excel nach PowerPoint kopieren. Jede Zeile ergibt eine neue Folie. Der Titel darf keinen Zeilenumbruch erhalten, muss also eine Zeile bleiben. Die Schriftgröße darf nur angepasst werden, wenn ein Zeilenumbruch entsteht. Die Powerpoint Präsentation wird auf dem Desktop (optional im TEMP - Ordner) gespeichert. Ist die Datei schon vorhanden - ohne Nachfrage überschreiben. Ohne eine philosophische Grundsatzdiskussion über den Hintergrund der Aktion, wie geht das?

I want to copy text from Excel to PowerPoint. Each line is a new slide. The title may not receive a line break, must therefore remain a row. The font size can be adjusted only when a line break occurs. The PowerPoint presentation is on the desktop (optional in the TEMP - folder) saved. If the file already exists - overwrite without asking. Without a philosophical principle discussion about the background of the action, how does it work?

Das war der erste Blogeintrag zum Thema... / This was the first blog entry on the topic...

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

Option Explicit
Dim blnTMP As Boolean
' Name der zu speichernden PowerPoint - Präsentation 
Const strPPSave As String = "TitleSubtitleFromExcel"
' Konstante für Worksheet - also gegebenenfalls anpassen!!! 
Const strSheet As String = "Sheet1"
' Slide mit Titel und Subtitel in PowerPoint 
' Liste der möglichen Konstanten folgt unten 
Const ppLayoutTitle = 1
' Objektvariable für Applikation 
Dim objPP As Object
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 18.03.2013 
' Purpose   : PowerPoint - new Presentation - slide add - list in Excel... 
' Purpose   : The title may not receive a line break... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    ' Variablendeklaration 
    Dim objPPShape1 As Object
    Dim objPPShape2 As Object
    Dim objPPSlide As Object
    Dim objPPNewP As Object
    Dim lngLastRow As Long
    Dim lngCount As Long
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo 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
    End With
    ' 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")
    If Not objPP Is Nothing Then
        ' Letzte Zeile in Worksheet "Sheet1" in Spalte A, 
        ' also gegebenenfalls OBEN die Konstante anpassen!!! 
        With ThisWorkbook.Worksheets(strSheet)
            lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
                .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row)
        End With
        With objPP
            ' Neue Präsentation 
            Set objPPNewP = .Presentations.Add
            ' Vom Ende in Spalte A bis Zeile 2 in Excel 
            For lngLastRow = lngLastRow To 2 Step -1
            ' Neues Slide an Objektvariable übergeben 
                Set objPPSlide = .ActivePresentation.Slides.Add _
                    (1, ppLayoutTitle)
                With objPPSlide
                    ' Titel an Objektvariable übergeben 
                    Set objPPShape1 = .Shapes(1)
                    ' Text in Überschrift reinschreiben und Größe zuordnen 
                    With objPPShape1.TextFrame.TextRange
                        .Text = ThisWorkbook.Worksheets _
                            (strSheet).Cells(lngLastRow, 1).Value
                        .Font.Size = 50
                        lngCount = .Lines.Count
                        If lngCount > 1 Then
                            Do
                                .Font.Size = .Font.Size - 1
                                lngCount = .Lines.Count
                            Loop Until lngCount = 1
                        End If
                        'ActivePresentation.Slides(1).Shapes(1).TextFrame.TextRange.Lines.Count 
                    End With
                    ' Subtitel an Objektvariable übergeben 
                    Set objPPShape2 = .Shapes(2)
                    ' Text in Untertitel reinschreiben und Größe zuordnen 
                    With objPPShape2.TextFrame.TextRange
                        .Text = ThisWorkbook.Worksheets _
                            (strSheet).Cells(lngLastRow, 2).Value
                        .Font.Size = 25
                    End With
                End With
                Set objPPShape2 = Nothing
                Set objPPShape1 = Nothing
            Next lngLastRow
            ' Speichern auf dem Desktop 
            objPPNewP.SaveAs Environ$("UserProfile") & "\Desktop\" & strPPSave
            .Quit
            ' Speichern im TEMP - Ordner 
            'objPPNewP.SaveAs Environ$("TEMP") & "\" & strPPSave 
        End With
    Else
        MsgBox "Application not installed!"
    End If
Fin:
    ' Objektvariablen zurücksetzen 
    Set objPPShape2 = Nothing
    Set objPPShape1 = Nothing
    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
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : OffApp 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 18.03.2013 
' Purpose   : Start application... 
'-------------------------------------------------------------------------- 
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    On Error Resume Next
    Set objPP = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objPP = CreateObject(strApp & ".Application")
            If blnVisible = True Then
                On Error Resume Next
                objPP.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objPP
    Set objPP = Nothing
End Function

' 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 

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...