Simple VBA Script to merge or combine all the powerpoint files in a folder into a new one! Steps: Open a new presentation file and save it to the folder all the files you want to combine are in (you can move it later) Paste the code into the VBA window Run the InsertAllSlides macro and it will combine them.

Merge Multiple PPT VBA

Sub InsertAllSlides()
'  Insert all slides from all presentations in the same folder as this one
'  INTO this one; do not attempt to insert THIS file into itself, though.

    Dim vArray() As String
    Dim x As Long

    ' Change "*.PPT" to "*.PPTX" or whatever if necessary:
    EnumerateFiles ActivePresentation.Path & "\", "*.PPTX", vArray

    With ActivePresentation
        For x = 1 To UBound(vArray)
            If Len(vArray(x)) > 0 Then
                .Slides.InsertFromFile vArray(x), .Slides.Count
            End If
        Next
    End With

End Sub

Sub EnumerateFiles(ByVal sDirectory As String, _
    ByVal sFileSpec As String, _
    ByRef vArray As Variant)
    ' collect all files matching the file spec into vArray, an array of strings

    Dim sTemp As String
    ReDim vArray(1 To 1)

    sTemp = Dir$(sDirectory & sFileSpec)
    Do While Len(sTemp) > 0
        ' NOT the "mother ship" ... current presentation
        If sTemp <> ActivePresentation.Name Then
            ReDim Preserve vArray(1 To UBound(vArray) + 1)
            vArray(UBound(vArray)) = sDirectory & sTemp
        End If
        sTemp = Dir$
    Loop

End Sub

I have downloaded this script and attempted to use it, but a getting a compile error while running it to merge pptx files

Can you help me?

How can I keep source formatting? what do I add to this code to make it work? I tried differents things and not working :-(

Thanks for sharing! It works well!

I get error 52 on
sTemp = Dir$(sDirectory & sFileSpec)

Can anyone assist?

I get error 52 on sTemp = Dir$(sDirectory & sFileSpec)

Can anyone assist?

Seems to not work in Sharepoint folders (maybe neither on OneDrive) because of weird quirks in VBA handling those file paths.
In
`Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef vArray As Variant)
' collect all files matching the file spec into vArray, an array of strings

Dim sTemp As String
ReDim vArray(1 To 1)

sTemp = Dir$(sDirectory & sFileSpec)`

In sTemp = Dir$(sDirectory & sFileSpec) change sDirectory to the local file path of your presentation folder e.g. "C:\User\Yourfolder\" Then it works like a charm.

Hi! I could not make it works. I paste the code in a VBA project, tried to execute it, changed the directory like @tkehren sugested but when i ran it it did nothing. All files are in the same location as the main file.


What i am doing wrong? The main file is TESTE.pptm.

It did work now!
I had to change the variable sDirectory to the path of the folder such as sugested. If i don't do it, it loads as a sharepoint link and it breaks the script. I think it did not worked at the first try because i did not save the script (lol, i am used to VSCode and autosave). Thanks very much for the script, it really helped me.

I get error 52 on sTemp = Dir$(sDirectory & sFileSpec)
Can anyone assist?

Seems to not work in Sharepoint folders (maybe neither on OneDrive) because of weird quirks in VBA handling those file paths. In `Sub EnumerateFiles(ByVal sDirectory As String, _ ByVal sFileSpec As String, _ ByRef vArray As Variant) ' collect all files matching the file spec into vArray, an array of strings

Dim sTemp As String
ReDim vArray(1 To 1)

sTemp = Dir$(sDirectory & sFileSpec)`

In sTemp = Dir$(sDirectory & sFileSpec) change sDirectory to the local file path of your presentation folder e.g. "C:\User\Yourfolder\" Then it works like a charm.

Hello everyone, I'm new to the community but I'm working on joining two PowerPoint presentations but for certain slides using a text file (batch guide), but I haven't been able to get it to work. I'm sharing my code with you in case anyone has any suggestions to make it work, I would really appreciate it. A hug to everyone.

..................
Sub InsertAllSlidesFromBatch()
Dim fso As Object
Dim fileStream As Object
Dim line As String
Dim parts As Variant
Dim filePath As String
Dim slideNumber As Integer
Dim pptMain As Presentation
Dim fd As FileDialog
Dim savePath As String

On Error GoTo ErrorHandler


Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
    .Title = "Selecciona el archivo batch"
    .Filters.Add "Archivos de texto", "*.txt", 1
    .AllowMultiSelect = False
    If .Show = -1 Then
        batchFilePath = .SelectedItems(1)
    Else
        MsgBox "No se seleccionó ningún archivo. Abortando.", vbExclamation
        Exit Sub
    End If
End With


Set pptMain = Presentations.Add


Set fso = CreateObject("Scripting.FileSystemObject")
Set fileStream = fso.OpenTextFile(batchFilePath, 1)

Do While Not fileStream.AtEndOfStream
    line = fileStream.ReadLine
    If Trim(line) <> "" Then
        parts = Split(line, ",")
        If UBound(parts) = 1 Then
            slideNumber = CInt(Trim(parts(0)))
            filePath = Trim(parts(1))
            

            ProcessSlideFromBatch filePath, slideNumber, pptMain
        Else
            MsgBox "Formato de línea incorrecto: " & line, vbExclamation
        End If
    End If
Loop


fileStream.Close


Set fd = Application.FileDialog(msoFileDialogSaveAs)
With fd
    .Title = "Guardar presentación combinada"
    .Filters.Add "Presentaciones de PowerPoint", "*.pptx", 1
    .InitialFileName = "Presentación_Combinada_" & Format(Now, "yyyymmdd_hhnnss") & ".pptx"
    If .Show = -1 Then
        savePath = .SelectedItems(1)
        pptMain.SaveAs savePath
        MsgBox "Presentación combinada guardada en: " & savePath, vbInformation
    Else
        MsgBox "No se seleccionó una ruta para guardar. Presentación no guardada.", vbExclamation
    End If
End With

Cleanup:
' Liberar objetos
On Error Resume Next
If Not fileStream Is Nothing Then fileStream.Close
Set fso = Nothing
Set fileStream = Nothing
Set fd = Nothing
If Not pptMain Is Nothing Then pptMain.Close
Exit Sub

ErrorHandler:
MsgBox "Se produjo un error: " & Err.Description, vbCritical
Resume Cleanup
End Sub

Sub ProcessSlideFromBatch(filePath As String, slideNumber As Integer, pptMain As Presentation)
Dim pptSource As Presentation

On Error GoTo SlideError


If Dir(filePath) = "" Then
    MsgBox "Archivo no encontrado: " & filePath, vbExclamation
    Exit Sub
End If


Set pptSource = Presentations.Open(filePath, WithWindow:=msoFalse)


If slideNumber > 0 And slideNumber <= pptSource.Slides.Count Then

    pptMain.Slides.InsertFromFile filePath, pptMain.Slides.Count, slideNumber, slideNumber
Else
    MsgBox "Número de diapositiva inválido: " & slideNumber & " en " & filePath, vbExclamation
End If


pptSource.Close
Set pptSource = Nothing
Exit Sub

SlideError:
MsgBox "Error al procesar la diapositiva del archivo: " & filePath & vbCrLf & Err.Description, vbCritical
If Not pptSource Is Nothing Then pptSource.Close
Set pptSource = Nothing
End Sub

...........................

How can I keep source formatting? what do I add to this code to make it work?