Move (Cut&Paste) Powerpoint Slides with Sections information by VBA - vba

Question

I am looking for a solution to select some slides and cut or copy and paste at another location while keeping the section information.
I have seen PPT does not support it out of the box (see http://answers.microsoft.com/en-us/office/forum/office_2013_release-powerpoint/copying-sections-to-a-new-powerpoint/2c723b0d-d465-4ab6-b127-6fdfc195478c?db=5)
and also some VBA Script examples here Exporting PowerPoint sections into separate files
PPTalchemy provides some Add-In but unfortunately the code is not available. See here http://www.pptalchemy.co.uk/powerpoint_hints_and_tips_tutorials.html#2010
Moreover it does not suit to move sections easily within the same presentation.
Any idea how to do this?
Many thanks.
Thierry

Answer 1

To move a section within a presentation, including all slides within the section, call this procedure with the index of the section to be moved and it's new location:
Option Explicit
' ********************************************************************************
' VBA Macro for PowerPoint, written by Jamie Garroch of http://YOUpresent.co.uk/
' ********************************************************************************
' Purpose : Moves a specified section of slides to a new section location
' Inputs : lSectionIndex - the index of the section to be moved
' lNewPosition - the index of the position to move to
' Outputs : None.
' ********************************************************************************
Public Sub MoveSection(lSectionIndex As Long, lNewPosition As Long)
On Error GoTo errorhandler
With ActivePresentation
.SectionProperties.Move lSectionIndex, lNewPosition
End With
Exit Sub
errorhandler:
Debug.Print "Couldn't move section due to the following error: " & Err & ", " & Err.Description
End Sub

Answer 2

This is finally the code I use to move multiple sections selected by slides:
Sub MoveSelectedSections()
' Slides are copied ready to be pasted
Dim lngNewPosition As Long
'Debug.Print ""
'Debug.Print "###Move Sections..."
lngNewPosition = InputBox("Enter a destination section index:")
lngNewPosition = CInt(lngNewPosition) ' Convert String to Int
Call MoveSectionsSelectedBySlides(ActivePresentation, lngNewPosition)
End Sub
Function MoveSectionsSelectedBySlides(oPres As Presentation, lNewPosition As Long)
On Error GoTo errorhandler
' Activate input presentation
oPres.Windows(1).Activate
' Get Selected Sections Indexes
' http://www.thespreadsheetguru.com/the-code-vault/2014/4/3/copy-selected-slides-into-new-powerpoint-presentation
Dim i, cnt As Integer
Dim SelectedSlides As SlideRange
Dim SectionIndexes() As Long
If ActiveWindow.Selection.Type <> ppSelectionSlides Then
MsgBox "No slides selected"
Exit Function
End If
Set SelectedSlides = ActiveWindow.Selection.SlideRange
' selection order is reverse see http://www.pptfaq.com/FAQ00869_Create_a_custom_show_from_current_slide_selection_using_VBA.htm
'Fill an array with sectionIndex numbers
ReDim SectionIndexes(1 To SelectedSlides.Count)
cnt = 0
For i = 1 To SelectedSlides.Count
' Check if already present in array
If Not Contains(SectionIndexes, SelectedSlides(i).sectionIndex) Then
cnt = cnt + 1
SectionIndexes(cnt) = SelectedSlides(i).sectionIndex
End If
Next i
ReDim Preserve SectionIndexes(1 To cnt)
' Move Sections to lNewPosition, first last
For i = 1 To cnt
With oPres
.SectionProperties.Move SectionIndexes(i), lNewPosition
End With
Debug.Print "Section #" & SectionIndexes(i) & " moved to " & lNewPosition
Next i
Exit Function
errorhandler:
Debug.Print "Couldn't move section due to the following error: " & Err & ", " & Err.Description
End Function
Function Contains(arr, v) As Boolean
' http://stackoverflow.com/a/18769246/2043349
Dim rv As Boolean, i As Long ' Default value of boolean is False
For i = LBound(arr) To UBound(arr)
If arr(i) = v Then
rv = True
Exit For
End If
Next i
Contains = rv
End Function