Excel Table to Powerpoint Slides

Das folgende Makro erstellt aus einer Excel-Tabelle zeilenweise Folien in PowerPoint.

Aufgabe: Aus den Zeilen einer Excel-Tabelle sollen einzelne Folien einer PowerPoint Präsentation erstellt werden.

Vorgehen

• Erstellen einer neuen PowerPoint-Präsentation
• Das Makro mit Hilfe der Entwicklertools in die Präsentation einfügen und starten.
  • Makro CreateLayoutFromExcel ausführen, um ein CustomLayout aus der ersten Tabelle der Excel-Datei zu erzeugen
  • Makro CreateSlidesFromExcel ausführen, um die Slides aus der ersten Tabelle der Excel-Dateizu erstellen
• Anschließend kann die Layout-Folie verschönert werden. Die Änderungen der Layout-Folie werden für alle Folien übernommen, so dass die Folien einheitlich gestaltet sind.
• Bei Änderungen der Excel-Tabelle müssen noch alle Folien gelöscht und mit dem Makro neu erstellt werden.

Musterfolie

Option Explicit ' Optionen und Konstanten ' MS Office 2010 Makro ' (c) 2018 Thomas Arend ' --- ' Unter "Extras - Verweise" muss die Microsoft Excel 14.0 Object Library ausgewählt werden

' Name of the CustomLayout

Const LayoutName As String = "ExcelColumn"

' Row which contains the title of the columns ' Normally this should be row 1 Const offsetRow As Long = 1

' ' Select Excel file '

Private Function FileSelected() As String

Dim MyFile As FileDialog

Set MyFile = Application.FileDialog(msoFileDialogOpen) With MyFile

 .Title = "Choose File"
 .AllowMultiSelect = False
 If .Show <> -1 Then
   Exit Function
 End If
 FileSelected = .SelectedItems(1)

End With

End Function

' ' Get a CustomLayout by name. ' There is no builtin function to do this. '

Private Function getLayoutByName(LOName As String) As CustomLayout

Dim tmpLayout As CustomLayout Dim i As Long

Set tmpLayout = ActivePresentation.SlideMaster.CustomLayouts(ppLayoutBlank) For i = 1 To ActivePresentation.SlideMaster.CustomLayouts.count

 If ActivePresentation.SlideMaster.CustomLayouts(i).Name = LOName Then
 Set tmpLayout = ActivePresentation.SlideMaster.CustomLayouts(i)
 End If

Next

Set getLayoutByName = tmpLayout

End Function

' ' Add a Custom Layout ' The name is in the Constant LayoutName '

Private Function AddCustomLayout() As CustomLayout

 Dim MyLayout As CustomLayout
 Dim i As Long
 
 Set MyLayout = ActivePresentation.SlideMaster.CustomLayouts.Add(1)
 MyLayout.Name = LayoutName
 MyLayout.Preserved = True

  Set AddCustomLayout = MyLayout
   

End Function

' ' Add Labels to the Custom Layout ' The title of the labels is in the row offsetRow of the table ' Assumes that column 1 is the first used column '

Private Sub AddMyLables(MyLayout As CustomLayout, MyWorkSheet As Excel.Worksheet, Optional ByVal offsetRow As Long = 1)

 Dim i As Long
 Dim lastColumn As Long
 
 ' Objekte für Labels
 
 With MyWorkSheet.UsedRange
   lastColumn = .Columns(.Columns.count).Column
 End With
    
 For i = 1 To lastColumn
     With MyLayout.Shapes.AddShape(Type:=msoShapeRectangle, Left:=50, Top:=(i + 2) * 40, Width:=160, Height:=24)
   .Fill.BackColor.RGB = RGB(160, 240, 255)
     .TextFrame.TextRange.Font.Size = 16
     .TextFrame.TextRange.ParagraphFormat.Bullet.Visible = msoFalse
     .TextFrame.TextRange.Text = MyWorkSheet.Cells(offsetRow, i).Text
   End With
 Next
   

End Sub

' ' Add placeholders for the number of used columns in table ' Assumes that column 1 is the first used column '

Private Sub AddMyPlaceholders(MyLayout As CustomLayout, MyWorkSheet As Excel.Worksheet)

 Dim i As Long
 Dim lastColumn As Long

 With MyWorkSheet.UsedRange
   lastColumn = .Columns(.Columns.count).Column
 End With
  
 ' Add Placeholders für Werte
 
 For i = 1 To lastColumn
   With MyLayout.Shapes.AddPlaceholder(Type:=ppPlaceholderBody, Left:=250, Top:=(i + 2) * 40, Width:=400, Height:=32)
   .Fill.BackColor.RGB = RGB(240, 240, 240)
     .TextFrame.TextRange.Font.Size = 24
     .TextFrame.TextRange.ParagraphFormat.Bullet.Visible = msoFalse
     .TextFrame.TextRange.Text = "Ph " & Str(i) & " / " & MyWorkSheet.Cells(offsetRow, i).Text
   End With
 Next

End Sub

' ' Create a cutom layout for the first sheet in an Excel file. '

Public Sub CreateLayoutFromExcel()

Dim xlAppl As Excel.Application Dim xlWBook As Excel.Workbook Dim xlWSheet As Excel.Worksheet Dim pptLayout As CustomLayout

Dim ExcelFileName As String

' Numemr der Überschrifetenzeile

'Open the Excel workbook. Get file with dialog ExcelFileName = FileSelected

With Application.ActivePresentation.CustomDocumentProperties

   .Add Name:="ExcelFileName", _
       LinkToContent:=False, _
       Type:=msoPropertyTypeString, _
       Value:=ExcelFileName

End With

If ExcelFileName <> "" Then

 ' Create Excel application object
 Set xlAppl = CreateObject("Excel.Application")
 ' Access Workbook
 Set xlWBook = xlAppl.Workbooks.Open(ExcelFileName, False, True)

 ' Access first worksheet
 Set xlWSheet = xlWBook.Worksheets(1)

 ' 1. Create as Custom Lauyout
 ' 2. Create Labels on the Layout
 ' 3. Create Placeholders on the Layout

 Set pptLayout = AddCustomLayout()

 Call AddMyLables(pptLayout, xlWSheet, offsetRow)
 Call AddMyPlaceholders(pptLayout, xlWSheet)

 ' Close Excel

 Set xlWSheet = Nothing
 xlWBook.Close savechanges:=False
 xlAppl.Quit
 Set xlAppl = Nothing
 

Else

 Call MsgBox("100 - No file selected", vbOKOnly, "Error")

End If

End Sub

' ' Create all slides form the used rows of the table ' Assumes that the row after the title row (offsetRow) is the first datat row. ' Assumes that the layout has a placeholder number 1 for the title

Public Sub CreateSlidesFromExcel()

Dim xlAppl As Excel.Application Dim xlWBook As Excel.Workbook Dim xlWSheet As Excel.Worksheet Dim pptSlide As Slide Dim pptLayout As CustomLayout

Dim ExcelFileName As String Dim i, j As Long Dim lastRow, lastColumn As Long

ExcelFileName = Application.ActivePresentation.CustomDocumentProperties("ExcelFileName")

If ExcelFileName <> "" Then

 ' Create Excel application object
 Set xlAppl = CreateObject("Excel.Application")

 ' Open the Excel workbook. Change the filename here.
 Set xlWBook = xlAppl.Workbooks.Open(ExcelFileName, False, True)

 ' Grab the first Worksheet in the Workbook
 ' Change parameter 1 to number of the sheet an other sheet should be used
 
 Set xlWSheet = xlWBook.Worksheets(1)
 
 ' Get previously added customer layout
 
 Set pptLayout = getLayoutByName(LayoutName)

 ' Find last used row and column

 With xlWSheet.UsedRange
   lastRow = .Row - 1 + .Rows.count
   lastColumn = .Columns(.Columns.count).Column
 End With
 
 ' Check if there are enough placeholders on the slide and
 ' that the table is not to large
 
 If lastColumn + 1 > pptLayout.Shapes.Placeholders.count Then
   If MsgBox("Die Tabelle mehr Spalten (" & Str(lastColumn) & ") als das Layout Platzhalter (" & Str(pptLayout.Shapes.Placeholders.count - 1) & "). Reduziere Spalten oder abbrechen?", vbOKCancel, "Mehr Spalten als Platzhalter") = vbCancel Then
     Exit Sub
   Else
     lastColumn = pptLayout.Shapes.Placeholders.count - 1
   End If
 End If

 If lastRow > 200 Then
   If MsgBox("Die Tabelle hat " & Str(lastRow) - 1 & " Zeilen. Abbrechen?", vbOKCancel, "Große Tabelle") = vbCancel Then
     Exit Sub
   End If
 End If

 ' Create one slide for each row and fill placeholders with values of the corresponding row

 For i = lastRow To offsetRow + 1 Step -1
 
   ' Add a new Slide at the start of the presenteion when LgNr not empty
   Set pptSlide = ActivePresentation.Slides.AddSlide(1, pptLayout)
 
   ' Fill new slide with labels and values
   With pptSlide
   
     ' Insert values from Excel sheet
   
     ' Set the title on the slide
     ' Change next line columns if the title is not in column 1
   
     .Shapes(1).TextFrame.TextRange.Text = xlWSheet.Cells(i, 1).Text
   
     ' Alternative
     ' .Shapes(1).TextFrame.TextRange.Text = xlWSheet.Cells(i, 1).Text & " - " & xlWSheet.Cells(i, 2).Text
   
     ' Fill Placeholders
     For j = 1 To lastColumn
       .Shapes(j + 1).TextFrame.TextRange.Text = xlWSheet.Cells(i, j).Text
     Next ' j = 1 To lastColumn
 
   End With ' pptSlide

 Next ' i = lastRow To offsetRow + 1 Step -1

 Set xlWSheet = Nothing
 xlWBook.Close savechanges:=False
 xlAppl.Quit
 Set xlAppl = Nothing

Else

 Call MsgBox("200 - Empty file name for table!", vbOKOnly, "Error")

End If ' ExcelFileName <> ""

End Sub