Dim pptApp As Object
Sub copyAllSlidesFromMultipleFiles()
'Prompt the user to select a folder for the target presentation
Dim targetFolderPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder for the Target Presentation"
.ButtonName = "Select"
.AllowMultiSelect = False
If .Show = -1 Then
targetFolderPath = .SelectedItems(1) & ""
Else
MsgBox "No folder selected for the target presentation"
Exit Sub
End If
End With
'Search for the latest .pptm file in the specified folder
Dim targetFileName As String
Dim latestFile As String
Dim latestDate As Date
targetFileName = Dir(targetFolderPath & "*.pptm")
Do While targetFileName <> ""
If FileDateTime(targetFolderPath & targetFileName) > latestDate Then
latestFile = targetFileName
latestDate = FileDateTime(targetFolderPath & targetFileName)
End If
targetFileName = Dir()
Loop
'Check if a file was found
If latestFile = "" Then
MsgBox "No PowerPoint files found in the specified folder for the target presentation"
Exit Sub
End If
'Set the latest presentation in the specified folder as the target presentation
Dim targetPresentation As Presentation
Set targetPresentation = Presentations(targetFolderPath & latestFile)
'Prompt the user for the number of source presentations
Dim numSourcePresentations As Integer
numSourcePresentations = InputBox("Enter the number of source presentations:")
'Prompt the user to select each source presentation and copy its slides to the target presentation
Dim i As Integer
For i = 1 To numSourcePresentations
'Prompt the user to select a folder for the source presentation
Dim sourceFolderPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder for Source Presentation " & i
.ButtonName = "Select"
.AllowMultiSelect = False
If .Show = -1 Then
sourceFolderPath = .SelectedItems(1) & ""
Else
MsgBox "No folder selected for source presentation " & i
Exit Sub
End If
End With
'Search for the most recent .pptx or .pptm file in the specified folder for the source presentation
Dim sourceFileName As String
Dim mostRecentFile As String
Dim mostRecentDate As Date
sourceFileName = Dir(sourceFolderPath & "*.pptx")
Do While sourceFileName <> ""
If FileDateTime(sourceFolderPath & sourceFileName) > mostRecentDate Then
mostRecentFile = sourceFileName
mostRecentDate = FileDateTime(sourceFolderPath & sourceFileName)
End If
sourceFileName = Dir()
Loop
sourceFileName = Dir(sourceFolderPath & "*.pptm")
Do While sourceFileName <> ""
If FileDateTime(sourceFolderPath & sourceFileName) > mostRecentDate Then
mostRecentFile = sourceFileName
mostRecentDate = FileDateTime(sourceFolderPath & sourceFileName)
End If
sourceFileName = Dir()
Loop
'Check if a file was found for the source presentation and open it if it was found.
If mostRecentFile <> "" Then
Dim pptApp As Object
If PowerPointIsRunning() Then
Set pptApp = GetObject(, "Powerpoint.Application")
Else
Set pptApp = CreateObject("Powerpoint.Application")
End If
Dim sourcePresentation As Object
Set sourcePresentation = pptApp.Presentations.Open(sourceFolderPath & mostRecentFile)
'Copy all non-hidden slides from the source presentation to the target presentation after the currently selected slide.
If targetPresentation.Slides.Count = 0 Then
MsgBox "Target presentation is empty"
Exit Sub
End If
Dim slide As slide
Dim currentIndex As Long
currentIndex = targetPresentation.Windows(1).Selection.SlideRange.SlideIndex
For Each slide In sourcePresentation.Slides
If Not slide.SlideShowTransition.Hidden Then
slide.Copy
targetPresentation.Slides.Paste currentIndex + 1
currentIndex = currentIndex + 1
End If
Next slide
'Close the source presentation after copying its slides to the target presentation.
sourcePresentation.Close
Set sourcePresentation = Nothing
Else
MsgBox "No PowerPoint files found in specified folder for Source Presentation " & i
End If
Next i
End Sub
Function PowerPointIsRunning() As Boolean
Dim pptApp As Object
On Error Resume Next
Set pptApp = GetObject(, "Powerpoint.Application")
If Not pptApp Is Nothing Then
PowerPointIsRunning = True
Else
PowerPointIsRunning = False
End If
Set pptApp = Nothing
End Function
Bookmarks