Sub Auto_Open()

    For Each toolbar In Application.CommandBars
        Debug.Print toolbar.Name
        If toolbar.Name = "Menu Bar" Then Exit For
    Next toolbar

    If Not toolbar.Controls(toolbar.Controls.Count - 1).Caption = "Import Excel data" Then
        Set NewMenu = toolbar.Controls.Add(Type:=msoControlPopup, Before:=toolbar.Controls.Count, Temporary:=True)
        NewMenu.Caption = "Import Excel data"
        NewMenu.OnAction = "Import_Excel_data"
    End If

End Sub


Sub Import_Excel_data()

    Set PP = ActivePresentation
    Set excel = CreateObject("Excel.application")

    Application.FileDialog(Type:=msoFileDialogOpen).Show
    If Application.FileDialog(Type:=msoFileDialogOpen).SelectedItems.Count = 0 Then GoTo cancel
    Set Workbook = excel.Workbooks.Open(Application.FileDialog(Type:=msoFileDialogOpen).SelectedItems.Item(1))

    sheetname = InputBox(Prompt:="Please select the Excel sheet name to import from", Title:="Sheet name to import", Default:=Workbook.Sheets(1).Name)

    On Error GoTo cancel
    lastrow = Workbook.Sheets(sheetname).UsedRange.Rows.Count
    On Error GoTo 0

    If lastrow > PP.Slides.Count Then expandslide = MsgBox(Prompt:= _
                "You have more data rows in Excel than slides in PowerPoint." & Chr(13) & _
                "Rows in Sheet '" & sheetname & "': " & lastrow & Chr(13) & _
                "PowerPoint slides: " & PP.Slides.Count & Chr(13) & _
                Chr(13) & _
                "Should the last slide " & lastrow - PP.Slides.Count & "x be copied?" _
                , Title:="More data rows than slides", Buttons:=vbYesNo)

    If expandslide = 2 Then GoTo cancel
    If expandslide = 6 Then
        PP.Slides(PP.Slides.Count).Copy
        For i = PP.Slides.Count + 1 To lastrow
            PP.Slides.Paste
        Next
    End If

    toomuchdata = False
    For i = 1 To PP.Slides.Count
        For j = 1 To PP.Slides(i).Shapes.Count
            If PP.Slides(i).Shapes(j).HasTextFrame Then
                PP.Slides(i).Shapes(j).TextFrame.TextRange.Text = Workbook.Sheets(sheetname).Cells(i, j)
            End If
        Next j

        lastcol = Workbook.Sheets(sheetname).Cells(1, Workbook.Sheets(sheetname).Columns.Count).End(Direction:=-4159).Column
        If lastcol > PP.Slides(i).Shapes.Count Then toomuchdata = True
    Next i

    If toomuchdata Then MsgBox "Warning: There was more data than textfields to fill. This data was skipped"

cancel:
    excel.Quit
    Set PP = Nothing
    Set Workbook = Nothing
    Set excel = Nothing

End Sub