VBA Powerpoint Export Custom Shows

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