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
• Anlegen einer Folie mit doppelt so vielen Platzhaltern für die Zellenwerte der Tabelle, wie die Tabelle Spalten besitzt.
• Das Makro mit Hilfe der Entwicklertools in die Präsentation einfügen und starten. Die erste Hälfte der Platzhalter wird durch das Makro mit den Spaltenüberschriften (Zeile 1) der Tabelle gefüllt. Diese Platzhalter dienen als Label. Die zweite Hälfte wird mit den Zellwerten jeweils einer Zeile gefüllt.
• 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 werden alle Folien gelöscht und mit dem Makro neu erstellt.

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