Header
Combine or join many PowerPoint Presentations!

INDEX

 

Jigsaws
Sounds
Video
Custom Shows
vba code
NaviSlides
Games for teachers
Bullets
Triggers
Security
Flash Cards
Multiple Instances
PowerPoint 2007
Mail Merge
Random events
Animation
Hyperlinks
Set spellcheck language


Home buttonTutorial buttonContact buttonProducts button


Joiner

This is a vba routine that will quickly combine several presentations into one larger presentation. If you are not familiar with vba and macro security you should first read PowerPoint vba for beginners

To use place a copy of all of the presentations EXCEPT the first in a folder on your desktop called "joiner" (no quotes)

Open the first presentation (Make sure you use a COPY) and press Alt f11 to open the vbe editor. INSERT > Module and paste in this code

Sub joiner()
Dim sFileTyp As String
Dim sFileName As String
Dim oDonor As Presentation
Dim otarget As Presentation
Dim i As Integer
On Error GoTo errhandler
sFileTyp = "*.PPT" ' change this for .pptx or pps

sFileName = Dir$(Environ("USERPROFILE") & "\Desktop\joiner\" & sFileTyp)
Set otarget = ActivePresentation
Do While sFileName <> ""
Set oDonor = Presentations.Open(Environ("USERPROFILE") & "\Desktop\joiner\" & sFileName, msoFalse)
For i = 1 To oDonor.Slides.Count
oDonor.Slides(i).Copy
With otarget.Slides.Paste(otarget.Slides.Count + 1)
.Design = oDonor.Slides(i).Design
.ColorScheme = oDonor.Slides(i).ColorScheme
End With
Next i
oDonor.Close
Set oDonor = Nothing
sFileName = Dir()
Loop
Exit Sub
errhandler:
MsgBox "Sorry, there was an error"
End Sub

Run the code to combine the presentations

If the order of files is important this second method sorts the files alphabetically before inserting slides.

Sub Joiner2()
Dim strName As String
Dim names() As String
Dim otarget As Presentation
Dim osource As Presentation
Dim i As Long
Dim j As Long
Dim strBuffer1 As String
Dim strFolder As String
Set otarget = Presentations.Add
ReDim names(1 To 1)
strFolder = Environ("USERPROFILE") & "\Desktop\joiner\"
strName = Dir$(strFolder & "*.PPTX")
While strName <> ""
names(UBound(names)) = strName
ReDim Preserve names(1 To UBound(names) + 1)
strName = Dir()
Wend
If UBound(names) > 1 Then
'sort
For i = 1 To UBound(names) - 1
For j = (i + 1) To UBound(names) - 1
If UCase(names(i)) > UCase(names(j)) Then
strBuffer1 = names(j)
names(j) = names(i)
names(i) = strBuffer1
End If
Next
Next
End If
If UBound(names) > 0 Then
For i = 1 To UBound(names) - 1
otarget.Slides.InsertFromFile strFolder & names(i), otarget.Slides.Count
Next i
End If
End Sub


 

 

 
 

Back to the Index Page

POWERPOINT BLOG

Articles on your favourite sport

Free Microsoft PowerPoint Advice, help and tutorials, Template Links
This website is sponsored by Technology Trish Ltd
© Technology Trish 2007
Registered in England and Wales No.5780175
PowerPoint® is a registered trademark of the Microsoft Corporation