如何将一个PPT两页两页拆分成多个PPT

user_ifqdh

各位老师好，我是PPT学习论坛的新人。我个人是教育工作者，一直都在跟PPT打交道。最近开始接触VBA，感觉对自己的工作非常有帮助。
我利用VBA，用Excel表格生成了一个英语短语的PPT。这个PPT上每两页是针对一个短语的解释。现在想把这个PPT，每两页保存为一个新的PPT，但是却摸不到方法了。
单页保存PPT可以用export解决，要保存多页的话，想请教一下各位老师，应当怎样操作才好？先行谢谢了！

另外，想向各位老师求教，目前见到的比较多的是关于excel的VBA教程，单纯讲PPT的却不多。请问哪里有比较好的学习资料，收费的也可以。

guojunhai

我在以下链接中找到一种解决办法，但是效率很低。如果是一个几兆的PPT，这样拆分下来要费好长的时间。不知道是否有更好更有效率的方法？http://www.pptfaq.com/FAQ01086_Break_a_presentation_up_into_several_smaller_presentations.htm
链接中的方法，是每次把整个PPT都另存一下，然后删掉多与的slides。代码如下：

• Sub SplitFile()
  
• 
  
•     Dim lSlidesPerFile As Long
  
•     Dim lTotalSlides As Long
  
•     Dim oSourcePres As Presentation
  
•     Dim otargetPres As Presentation
  
•     Dim sFolder As String
  
•     Dim sExt As String
  
•     Dim sBaseName As String
  
•     Dim lCounter As Long
  
•     Dim lPresentationsCount As Long     ' how many will we split it into
  
•     Dim x As Long
  
•     Dim lWindowStart As Long
  
•     Dim lWindowEnd As Long
  
•     Dim sSplitPresName As String
  
• 
  
•     On Error GoTo ErrorHandler
  
• 
  
•     Set oSourcePres = ActivePresentation
  
•     If Not oSourcePres.Saved Then
  
•         MsgBox "Please save your presentation then try again"
  
•         Exit Sub
  
•     End If
  
• 
  
•     lSlidesPerFile = CLng(InputBox("How many slides per file?", "Split Presentation"))
  
•     lTotalSlides = oSourcePres.Slides.Count
  
•     sFolder = ActivePresentation.Path & ""
  
•     sExt = Mid$(ActivePresentation.Name, InStr(ActivePresentation.Name, ".") + 1)
  
•     sBaseName = Mid$(ActivePresentation.Name, 1, InStr(ActivePresentation.Name, ".") - 1)
  
• 
  
•     If (lTotalSlides / lSlidesPerFile) - (lTotalSlides  lSlidesPerFile) > 0 Then
  
•         lPresentationsCount = lTotalSlides  lSlidesPerFile + 1
  
•     Else
  
•         lPresentationsCount = lTotalSlides  lSlidesPerFile
  
•     End If
  
• 
  
•     If Not lTotalSlides > lSlidesPerFile Then
  
•         MsgBox "There are fewer than " & CStr(lSlidesPerFile) & " slides in this presentation."
  
•         Exit Sub
  
•     End If
  
• 
  
•     For lCounter = 1 To lPresentationsCount
  
• 
  
•         ' which slides will we leave in the presentation?
  
•         lWindowEnd = lSlidesPerFile * lCounter
  
•         If lWindowEnd > oSourcePres.Slides.Count Then
  
•             ' odd number of leftover slides in last presentation
  
•             lWindowEnd = oSourcePres.Slides.Count
  
•             lWindowStart = ((oSourcePres.Slides.Count  lSlidesPerFile) * lSlidesPerFile) + 1
  
•         Else
  
•             lWindowStart = lWindowEnd - lSlidesPerFile + 1
  
•         End If
  
• 
  
•         ' Make a copy of the presentation and open it
  
•         sSplitPresName = sFolder & sBaseName & _
  
•                "_" & CStr(lWindowStart) & "-" & CStr(lWindowEnd) & "." & sExt
  
•         oSourcePres.SaveCopyAs sSplitPresName, ppSaveAsDefault
  
•         Set otargetPres = Presentations.Open(sSplitPresName, , , True)
  
• 
  
•         With otargetPres
  
•             For x = .Slides.Count To lWindowEnd + 1 Step -1
  
•                 .Slides(x).Delete
  
•             Next
  
•             For x = lWindowStart - 1 To 1 Step -1
  
•                 .Slides(x).Delete
  
•             Next
  
•             .Save
  
•             .Close
  
•         End With
  
• 
  
•     Next    ' lpresentationscount
  
• 
  
• NormalExit:
  
•     Exit Sub
  
• ErrorHandler:
  
•     MsgBox "Error encountered"
  
•     Resume NormalExitEnd Sub
  

复制代码

user_xiain

自己鼓捣出来第二种方法，虽然写得笨了点，但是还算是好用：

• Sub createNewPres()
  
• 
  
• Dim oldPres As Presentation, newPres As Presentation, fPath As String, fName As String
  
• Set oldPres = ActivePresentation
  
• Set newPres = Presentations.Add(True)
  
• fPath = oldPres.Path & ""
  
• For i = 1 To oldPres.Slides.Count Step 2
  
•     fName = oldPres.Slides(i).Shapes("Title 1").TextFrame.TextRange.Text
  
•    
  
•     oldPres.Slides(i).Copy
  
•     newPres.Slides.Paste
  
•     newPres.Slides(1).Design = oldPres.Slides(i).Design
  
•     newPres.Slides(1).ColorScheme = oldPres.Slides(i).ColorScheme
  
•     newPres.Slides(1).FollowMasterBackground = oldPres.Slides(i).FollowMasterBackground
  
•    
  
•     oldPres.Slides(i + 1).Copy
  
•     newPres.Slides.Paste
  
•     newPres.Slides(2).Design = oldPres.Slides(i + 1).Design
  
•     newPres.Slides(2).ColorScheme = oldPres.Slides(i + 1).ColorScheme
  
•     newPres.Slides(2).FollowMasterBackground = oldPres.Slides(i + 1).FollowMasterBackground
  
•    
  
•     newPres.SaveAs fPath & fName & ".ppt"
  
•     newPres.Close
  
•     Set newPres = Presentations.Add(True)
  
• Next i
  
• End Sub
  

复制代码