Automatically merging several presentations into one single presentation

Question

Hi,

I have about 10 different powerpoint presentations that I would like to merge into one single powerpoint presentation file.  If required then I could put those presentations into a separate folder - to ease life.

My question is: what kind of macro our routine would help to do this simple but recurring task.  Automation need is mainly to tackle the "recurrent" aspect.  Had it been a one-time affair then it would have been simpler to do it manually.

Many thanks in anticipation of an efficient solution

Answer 1

This macro should combine all of the pptx files in the folder "Files" on the desktop.

You may need to rename files to get the order correct or use the more complex method 2. Also be aware any internal links will break.

Sub importer()

Dim oTarget As Presentation

Dim strFolder As String

Dim strName As String

Dim oSource As Presentation

strFolder = Environ("USERPROFILE") & "\Desktop\Files" 'Files folder on Desktop

Set oTarget = Presentations.Add

strName = Dir$(strFolder & "*.PPTX")

While strName <> ""

oTarget.Slides.InsertFromFile strFolder & strName, oTarget.Slides.Count

strName = Dir()

Wend

End Sub

Sub Joiner()

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