PDA

View Full Version : Acomplex export from Excel to Powerpoint



Darthvader
06-21-2011, 11:04 AM
Hi All

I am a newbie but this site is looking fantastic already. Glad to be amongst all of you.

I have a query. I have been writing up a code which is supposed to read & store all the files in a user selected folder, allow the user to select which files he/she wants to open and export all the file contents in the order they were selected to a new Powerpoint file, save the new powerpoint file and close all other files.

The chosen files will only ever be xls, doc and ppt.

See my code below.

I have gone as far as getting the routine to open the selected files in the order they were selected.

All I need to do now is to get the coding to perform the copy paste task to powerpoint for each file opened (if its excel, then each worksheet to a slide, if its word, each page, pp... slide for slide)

I also want the macro to be smart enough to scale the worksheet/page/slide to fit the empty slide it is pasting to.

Can this be done?

Many Thanks

Sub openDocs()
Dim wdApp As Word.Application, wDoc As Word.Document
Dim pptApp As PowerPoint.Application, ppt As PowerPoint.Presentation
Sheets("List").Visible = True
Sheets("List").Select
Range("A1").Select
Do Until ActiveCell.Value = ""
Select Case LCase(Right(ActiveCell.Value, 3))
Case "xls"
Workbooks.Open Sheets("control").Range("A21") & ActiveCell.Value
Windows("PPoint Macro v0.3.xls").Activate
Sheets("List").Select
Case "doc"
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
Set wDoc = wdApp.Documents.Open(Sheets("control").Range("A21") & ActiveCell.Value)
wdApp.Visible = True
Case "ppt"
On Error Resume Next
Set pptApp = GetObject(, "Powerpoint.Application")
If Err.Number <> 0 Then
Set pptApp = CreateObject("PowerPoint.Application")
End If
On Error GoTo 0
pptApp.Visible = True
Set ppt = pptApp.Presentations.Open(Sheets("control").Range("A21") & ActiveCell.Value)
End Select
ActiveCell.Offset(1, 0).Select
Loop
Set wdApp = Nothing
Set pptApp = Nothing
Sheets("List").Visible = False
End Sub