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

PowerPoint Makro

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:=32)
    .Fill.BackColor.RGB = RGB(160, 240, 255)
      .TextFrame.TextRange.Font.Size = 24
      .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:=160, Height:=32)
    .Fill.BackColor.RGB = RGB(240, 240, 240)
      .TextFrame.TextRange.Font.Size = 24
      .TextFrame.TextRange.ParagraphFormat.Bullet.Visible = msoFalse
      .TextFrame.TextRange.Text = "Placeholder " & Str(i)
    End With
  Next

    
End Sub

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

Sub CreateLayoutFormExcel()

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

Dim pptLayout As CustomLayout

' Numemr der Überschrifetenzeile

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

'Open the Excel workbook. Get file with dialog
Set xlWBook = xlAppl.Workbooks.Open(FileSelected, True)

'Grab the first Worksheet in the Workbook
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

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

Sub CreateSlidesFormExcel()

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

Dim pptSlide As Slide
Dim pptLayout As CustomLayout
Dim i, j As Long
Dim lastRow, lastColumn As Long

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

' Open the Excel workbook. Change the filename here.
Set xlWBook = xlAppl.Workbooks.Open(FileSelected, 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)

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

' 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
    .Shapes(1).TextFrame.TextRange.Text = xlWSheet.Cells(i, 2).Text & " - " & xlWSheet.Cells(i, 3).Text
    For j = 1 To lastColumn
      .Shapes(j + 1).TextFrame.TextRange.Text = xlWSheet.Cells(i, j).Text
    Next
  
  End With

Next

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

End Sub

'
' Helping procedure to see which placeholder has wich number
'

Sub NameShapesInSlide()

Dim j As Long

With ActivePresentation.Slides(1)
 
  j = 1
  
  For Each s In .Shapes.Placeholders
    
    s.TextFrame.TextRange.Text = j
    j = j + 1
    
  Next
  

End With

End Sub