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

philhomic

各位老师好，我是ExcelHome的新人。我个人是教育工作者，一直都在跟PPT打交道。最近开始接触VBA，感觉对自己的工作非常有帮助。
我利用VBA，用Excel表格生成了一个英语短语的PPT。这个PPT上每两页是针对一个短语的解释。现在想把这个PPT，每两页保存为一个新的PPT，但是却摸不到方法了。
单页保存PPT可以用export解决，要保存多页的话，想请教一下各位老师，应当怎样操作才好？先行谢谢了！{:soso_e183:}
另外，想向各位老师求教，目前见到的比较多的是关于excel的VBA教程，单纯讲PPT的却不多。请问哪里有比较好的学习资料，收费的也可以。

philhomic

我在以下链接中找到一种解决办法，但是效率很低。如果是一个几兆的PPT，这样拆分下来要费好长的时间。不知道是否有更好更有效率的方法？http://www.pptfaq.com/FAQ01086_Break_a_presentation_up_into_several_smaller_presentations.htm

链接中的方法，是每次把整个PPT都另存一下，然后删掉多与的slides。代码如下：

1. Sub SplitFile()
   
2. 
   
3.     Dim lSlidesPerFile As Long
   
4.     Dim lTotalSlides As Long
   
5.     Dim oSourcePres As Presentation
   
6.     Dim otargetPres As Presentation
   
7.     Dim sFolder As String
   
8.     Dim sExt As String
   
9.     Dim sBaseName As String
   
10.     Dim lCounter As Long
    
11.     Dim lPresentationsCount As Long     ' how many will we split it into
    
12.     Dim x As Long
    
13.     Dim lWindowStart As Long
    
14.     Dim lWindowEnd As Long
    
15.     Dim sSplitPresName As String
    
16. 
    
17.     On Error GoTo ErrorHandler
    
18. 
    
19.     Set oSourcePres = ActivePresentation
    
20.     If Not oSourcePres.Saved Then
    
21.         MsgBox "Please save your presentation then try again"
    
22.         Exit Sub
    
23.     End If
    
24. 
    
25.     lSlidesPerFile = CLng(InputBox("How many slides per file?", "Split Presentation"))
    
26.     lTotalSlides = oSourcePres.Slides.Count
    
27.     sFolder = ActivePresentation.Path & ""
    
28.     sExt = Mid$(ActivePresentation.Name, InStr(ActivePresentation.Name, ".") + 1)
    
29.     sBaseName = Mid$(ActivePresentation.Name, 1, InStr(ActivePresentation.Name, ".") - 1)
    
30. 
    
31.     If (lTotalSlides / lSlidesPerFile) - (lTotalSlides \ lSlidesPerFile) > 0 Then
    
32.         lPresentationsCount = lTotalSlides \ lSlidesPerFile + 1
    
33.     Else
    
34.         lPresentationsCount = lTotalSlides \ lSlidesPerFile
    
35.     End If
    
36. 
    
37.     If Not lTotalSlides > lSlidesPerFile Then
    
38.         MsgBox "There are fewer than " & CStr(lSlidesPerFile) & " slides in this presentation."
    
39.         Exit Sub
    
40.     End If
    
41. 
    
42.     For lCounter = 1 To lPresentationsCount
    
43. 
    
44.         ' which slides will we leave in the presentation?
    
45.         lWindowEnd = lSlidesPerFile * lCounter
    
46.         If lWindowEnd > oSourcePres.Slides.Count Then
    
47.             ' odd number of leftover slides in last presentation
    
48.             lWindowEnd = oSourcePres.Slides.Count
    
49.             lWindowStart = ((oSourcePres.Slides.Count \ lSlidesPerFile) * lSlidesPerFile) + 1
    
50.         Else
    
51.             lWindowStart = lWindowEnd - lSlidesPerFile + 1
    
52.         End If
    
53. 
    
54.         ' Make a copy of the presentation and open it
    
55.         sSplitPresName = sFolder & sBaseName & _
    
56.                "_" & CStr(lWindowStart) & "-" & CStr(lWindowEnd) & "." & sExt
    
57.         oSourcePres.SaveCopyAs sSplitPresName, ppSaveAsDefault
    
58.         Set otargetPres = Presentations.Open(sSplitPresName, , , True)
    
59. 
    
60.         With otargetPres
    
61.             For x = .Slides.Count To lWindowEnd + 1 Step -1
    
62.                 .Slides(x).Delete
    
63.             Next
    
64.             For x = lWindowStart - 1 To 1 Step -1
    
65.                 .Slides(x).Delete
    
66.             Next
    
67.             .Save
    
68.             .Close
    
69.         End With
    
70. 
    
71.     Next    ' lpresentationscount
    
72. 
    
73. NormalExit:
    
74.     Exit Sub
    
75. ErrorHandler:
    
76.     MsgBox "Error encountered"
    
77.     Resume NormalExit
    
78. End Sub

复制代码

philhomic

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

1. Sub createNewPres()
   
2. 
   
3. Dim oldPres As Presentation, newPres As Presentation, fPath As String, fName As String
   
4. Set oldPres = ActivePresentation
   
5. Set newPres = Presentations.Add(True)
   
6. fPath = oldPres.Path & ""
   
7. For i = 1 To oldPres.Slides.Count Step 2
   
8.     fName = oldPres.Slides(i).Shapes("Title 1").TextFrame.TextRange.Text
   
9.    
   
10.     oldPres.Slides(i).Copy
    
11.     newPres.Slides.Paste
    
12.     newPres.Slides(1).Design = oldPres.Slides(i).Design
    
13.     newPres.Slides(1).ColorScheme = oldPres.Slides(i).ColorScheme
    
14.     newPres.Slides(1).FollowMasterBackground = oldPres.Slides(i).FollowMasterBackground
    
15.    
    
16.     oldPres.Slides(i + 1).Copy
    
17.     newPres.Slides.Paste
    
18.     newPres.Slides(2).Design = oldPres.Slides(i + 1).Design
    
19.     newPres.Slides(2).ColorScheme = oldPres.Slides(i + 1).ColorScheme
    
20.     newPres.Slides(2).FollowMasterBackground = oldPres.Slides(i + 1).FollowMasterBackground
    
21.    
    
22.     newPres.SaveAs fPath & fName & ".ppt"
    
23.     newPres.Close
    
24.     Set newPres = Presentations.Add(True)
    
25. Next i
    
26. 
    
27. End Sub

复制代码