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

Private Function FileSelected() As String

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



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


Set pptLayout = ActivePresentation.SlideMaster.CustomLayouts(ppLayoutBlank)
For i = 1 To ActivePresentation.SlideMaster.CustomLayouts.Count
  If ActivePresentation.SlideMaster.CustomLayouts(i).Name = "ExcelZeile" Then
  Set pptLayout = ActivePresentation.SlideMaster.CustomLayouts(i)
  End If
Next

' 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
Set xlWSheet = xlWBook.Worksheets(1)

'Loop through each used row in Column B

' Go through all columns until a column is empty

With xlWSheet.UsedRange
  lastRow = .Row - 1 + .Rows.Count
  lastColumn = .Columns(.Columns.Count).Column
End With


' Create one slide for each row and fill the textframes in the layout with the values of a row
' First row will be used als labels

For i = lastRow To 2 Step -1
  
  ' Add a new Slide at the start of the presenteion when LgNr not empty
  ActivePresentation.Slides.AddSlide 1, pptLayout
  
  ' Fill new slide with labels and values
  With ActivePresentation.Slides(1)
    
    ' Get values from Excel sheet
    For j = 1 To lastColumn
      ' Einfügen der Spaltenüberschriften als Label
      .Shapes(j).TextFrame.TextRange.Text = xlWSheet.Cells(1, j).Text
      ' Einfügen der Werte
      .Shapes(lastColumn + j).TextFrame.TextRange.Text = xlWSheet.Cells(i, j).Text
    Next
  
  End With

Next

Set xlWSheet = Nothing
Set xlWBoook = Nothing
xlAppl.Quit
Set xlAppl = Nothing

End Sub

Sub NameShapesInSlide()

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

End With

End Sub