Advertisement
Guest User

Untitled

a guest
Jan 28th, 2013
759
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Sub Auto_Open()
  2.  
  3.     For Each toolbar In Application.CommandBars
  4.         Debug.Print toolbar.Name
  5.         If toolbar.Name = "Menu Bar" Then Exit For
  6.     Next toolbar
  7.    
  8.     If Not toolbar.Controls(toolbar.Controls.Count - 1).Caption = "Import Excel data" Then
  9.         Set NewMenu = toolbar.Controls.Add(Type:=msoControlPopup, Before:=toolbar.Controls.Count, Temporary:=True)
  10.         NewMenu.Caption = "Import Excel data"
  11.         NewMenu.OnAction = "Import_Excel_data"
  12.     End If
  13.  
  14. End Sub
  15.  
  16.  
  17. Sub Import_Excel_data()
  18.  
  19.     Set PP = ActivePresentation
  20.     Set excel = CreateObject("Excel.application")
  21.    
  22.     Application.FileDialog(Type:=msoFileDialogOpen).Show
  23.     If Application.FileDialog(Type:=msoFileDialogOpen).SelectedItems.Count = 0 Then GoTo cancel
  24.     Set Workbook = excel.Workbooks.Open(Application.FileDialog(Type:=msoFileDialogOpen).SelectedItems.Item(1))
  25.  
  26.     sheetname = InputBox(Prompt:="Please select the Excel sheet name to import from", Title:="Sheet name to import", Default:=Workbook.Sheets(1).Name)
  27.  
  28.     On Error GoTo cancel
  29.     lastrow = Workbook.Sheets(sheetname).UsedRange.Rows.Count
  30.     On Error GoTo 0
  31.    
  32.     If lastrow > PP.Slides.Count Then expandslide = MsgBox(Prompt:= _
  33.                 "You have more data rows in Excel than slides in PowerPoint." & Chr(13) & _
  34.                 "Rows in Sheet '" & sheetname & "': " & lastrow & Chr(13) & _
  35.                 "PowerPoint slides: " & PP.Slides.Count & Chr(13) & _
  36.                 Chr(13) & _
  37.                 "Should the last slide " & lastrow - PP.Slides.Count & "x be copied?" _
  38.                 , Title:="More data rows than slides", Buttons:=vbYesNo)
  39.    
  40.     If expandslide = 2 Then GoTo cancel
  41.     If expandslide = 6 Then
  42.         PP.Slides(PP.Slides.Count).Copy
  43.         For i = PP.Slides.Count + 1 To lastrow
  44.             PP.Slides.Paste
  45.         Next
  46.     End If
  47.  
  48.     toomuchdata = False
  49.     For i = 1 To PP.Slides.Count
  50.         For j = 1 To PP.Slides(i).Shapes.Count
  51.             If PP.Slides(i).Shapes(j).HasTextFrame Then
  52.                 PP.Slides(i).Shapes(j).TextFrame.TextRange.Text = Workbook.Sheets(sheetname).Cells(i, j)
  53.             End If
  54.         Next j
  55.    
  56.         lastcol = Workbook.Sheets(sheetname).Cells(1, Workbook.Sheets(sheetname).Columns.Count).End(Direction:=-4159).Column
  57.         If lastcol > PP.Slides(i).Shapes.Count Then toomuchdata = True
  58.     Next i
  59.  
  60.     If toomuchdata Then MsgBox "Warning: There was more data than textfields to fill. This data was skipped"
  61.    
  62. cancel:
  63.     excel.Quit
  64.     Set PP = Nothing
  65.     Set Workbook = Nothing
  66.     Set excel = Nothing
  67.    
  68. End Sub
Advertisement
RAW Paste Data Copied
Advertisement