Sub Extract()
Dim prsThis As Presentation
Dim prsThat As Presentation
Dim sldThis As Slide
Dim sldThat As SlideRange
Dim nss As NamedSlideShow
Dim strName As String
Dim i As Integer
Set prsThis = ActivePresentation
For Each nss In prsThis.SlideShowSettings.NamedSlideShows
Set prsThat = Application.Presentations.Add
prsThat.ApplyTemplate prsThis.FullName
For i = 1 To nss.Count
Set sldThis = prsThis.Slides.FindBySlideID(nss.SlideIDs(i))
sldThis.Copy
Set sldThat = prsThat.Slides.Paste
sldThat.Design = prsThis.Designs(sldThis.Design.Index)
Next
strName = prsThis.FullName
prsThat.SaveAs Left(strName, Len(strName) - 4) & "-" & nss.Name
Next
End Sub