EXCEL copy to PPT PPT直接崩溃

caitjcai

大家好呀，我在excel写了VBA程序，把单元格的内容copy到PPT对应位置上，只copyA1单元格没事，又接着加上了，让它copyB1单元格，PPT就崩溃了，大家能帮忙看看吗？文档在附件，谢谢！

1. Sub CreatePowerPoint()
   
2. Dim activeSlide As PowerPoint.Slide
   
3. Dim i As Integer
   
4. Dim Model As Object
   
5. Set newPowerPoint = CreateObject("powerpoint.application")
   
6. Set Model = newPowerPoint.Presentations.Open(ThisWorkbook.Path & "\样本.pptx", , , msoTrue)
   
7. For i = 2 To 3
   
8. newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count).Duplicate
   
9. newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count - 1
   
10. Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count - 1)
    
11. On Error Resume Next
    
12. Range("A" & i).Activate
    
13. Worksheets("Sheet1").Range("A" & i).Copy
    
14. newPowerPoint.CommandBars.ExecuteMso "PasteSourceFormatting"
    
15. 'Paste to PowerPoint and position
    
16. activeSlide.Shapes.PasteSpecial DataType:=ppPasteSourceFormatting, DisplayAsIcon:=msoFalse
    
17. 'PowerPointApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
    
18. Set myShapeRange = activeSlide.Shapes(activeSlide.Shapes.Count)
    
19. 'Set position:
    
20. myShapeRange.Left = 450
    
21. myShapeRange.Top = 100
    
22. myShapeRange.Height = 200
    
23. myShapeRange.Width = 400
    
24. 'Clear The Clipboard
    
25. Application.CutCopyMode = False
    
26. Range("B" & i).Activate
    
27. Worksheets("Sheet1").Range("B" & i).Copy
    
28. newPowerPoint.CommandBars.ExecuteMso "PasteSourceFormatting"
    
29. 'Paste to PowerPoint and position
    
30. activeSlide.Shapes.PasteSpecial DataType:=ppPasteSourceFormatting, DisplayAsIcon:=msoFalse
    
31. 'PowerPointApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
    
32. Set myShapeRange = activeSlide.Shapes(activeSlide.Shapes.Count)
    
33. 'Set position:
    
34. myShapeRange.Left = 100
    
35. myShapeRange.Top = 100
    
36. myShapeRange.Height = 200
    
37. myShapeRange.Width = 400
    
38. 'Clear The Clipboard
    
39. Application.CutCopyMode = False
    
40. Next i
    
41. End Sub

复制代码

caitjcai

终于审核通过了，请大家帮忙！谢谢

opel-wong

你把这三句复制过来看看效果，

caitjcai

opel-wong 发表于 2020-9-1 18:41
你把这三句复制过来看看效果，

您好，感谢您的回复，这样不卡死了，但是我想要Ai,Bi,Ci都在一个页面显示，这样改的话，就各自一个页面了=。=还望您的解答！重新改代码也可以！

ning84

1. Private Sub del1()
   
2.     Dim Sld As Slide
   
3.     Dim Shp As Shape
   
4.     Dim ShpRng As ShapeRange
   
5.          Set Sld = Application.ActivePresentation.Slides(1)
   
6.          
   
7.          For Each Shp In Sld.Shapes
   
8.              Shp.Select msoFalse
   
9.          Next Shp
   
10.          Set ShpRng = Application.ActiveWindow.Selection.ShapeRange
    
11.          ShpRng.Copy
    
12. 
    
13.          For ii = 2 To 10
    
14.              Set Sld = Application.ActivePresentation.Slides.Add(ii, ppLayoutBlank)
    
15.              ActiveWindow.View.GotoSlide ii
    
16.              ActiveWindow.View.Paste
    
17.          Next ii
    
18. End Sub
    

复制代码

ning84

总算搞清楚ShapeRange的用法。
Set ShpRng = Sld.Shapes.Range(Array("C1", "C2", "N"))
比这种方法简单实用。

******************************
         For Each Shp In Sld.Shapes
             Shp.Select msoFalse
         Next Shp
         Set ShpRng = Application.ActiveWindow.Selection.ShapeRange

******************************

1. Private Sub del3()
   
2.      Dim Pres As Presentation
   
3.      Dim Sld As Slide
   
4.      Dim ShpRng As ShapeRange
   
5.          Set Pres = Application.ActivePresentation
   
6.          Set Sld = Pres.Slides(1)
   
7.          Set ShpRng = Sld.Shapes.Range(Array("C1", "C2", "N"))
   
8.          ShpRng.Select msoCTrue
   
9.          ShpRng.Copy
   
10. 
    
11.          For ii = 2 To 10
    
12.              Set Sld = Pres.Slides.Add(ii, ppLayoutBlank)
    
13.              ActiveWindow.View.GotoSlide ii
    
14.              ActiveWindow.View.Paste
    
15.          Next ii
    
16. End Sub
    

复制代码