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

Visual Basic Makros

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