使用vba在excel中爲每張幻燈片創建一個幻燈片

Question

我目前有一個工作代碼，可以從我的excel電子表格中獲取每張圖表，並創建一個PowerPoint演示文稿，將所有圖表放在同一張幻燈片中。我希望宏在每張幻燈片上放置四（4）個圖表，但我遇到了麻煩，任何幫助都會被讚賞。（注意：一旦它們在PowerPoint中，我還沒有調整圖表的大小，我會在處理完這些後我得到4每張幻燈片）我當前的代碼是看到下面

Private Sub CommandButton17_Click() 
'Add a reference to the Microsoft PowerPoint Library by: 
'1. Go to Tools in the VBA menu 
'2. Click on Reference 
'3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay 

'keep button in same location 
Set btn = ActiveSheet.Shapes("CommandButton17") 
With btn 
btLeft = .Left 
btTop = .Top 
End With 

'First we declare the variables we will be using 
    Dim newPowerPoint As PowerPoint.Application 
    Dim activeSlide As PowerPoint.Slide 
    Dim cht As Excel.ChartObject 

'Look for existing instance 
    On Error Resume Next 
    Set newPowerPoint = GetObject(, "PowerPoint.Application") 
    On Error GoTo 0 

'Let's create a new PowerPoint 
    If newPowerPoint Is Nothing Then 
     Set newPowerPoint = New PowerPoint.Application 
    End If 
'Make a presentation in PowerPoint 
    If newPowerPoint.Presentations.Count = 0 Then 
     newPowerPoint.Presentations.Add 
    End If 

'Show the PowerPoint 
    newPowerPoint.Visible = True 
'  newPowerPoint.ActivePresentation.ApplyTemplate _ 
'   "D:\Documents and Settings\austin.plantz\Desktop\Misc Projects\CSA PP Theme.thmx" 

'Loop through each chart in the Excel worksheet and paste them into the PowerPoint 
    For i = 1 To ActiveSheet.ChartObjects.Count 
     Set cht = ActiveSheet.ChartObjects(i) 

'   With ActivePresentation.SlideMaster 
'    .CustomLayouts.Add (1) 
'    .CustomLayouts(1).Name = "Title And Content" 
'   End With 

    'Add a new slide where we will paste the chart 
    If i - 1 Mod 4 = 0 Then 
     newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutTitle 
    End If 


     newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count 
     Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count) 

    'Copy the chart and paste it into the PowerPoint as a Metafile Picture 
     cht.Select 
     ActiveChart.ChartArea.Copy 
     activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select 

    'Set the title of the slide the same as the title of the chart 
     'activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text 

    'Adjust the positioning of the Chart on Powerpoint Slide 
     newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 165 
     newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 150 
     newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 400 

     activeSlide.Shapes(2).Width = 200 
     activeSlide.Shapes(2).Left = 505 

     activeSlide.Shapes(1).Top = 25 

    Next 

AppActivate ("Microsoft PowerPoint") 
Set activeSlide = Nothing 
Set newPowerPoint = Nothing 

End Sub 

Answer 1

首先改變你foreach循環對於

For i = 1 To ActiveSheet.ChartObjects.Count 
Set cht = ActiveSheet.ChartObjects(i) 

創建幻燈片之前然後把條件：

chartNum = (i - 1) Mod 4 
If chartNum = 0 Then 
    newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutTitle 
End If 

然後，放下GIC放置圖表每張幻燈片：

If chartNum = 0 Then 
     newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 50 
     newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 50 
    ElseIf chartNum = 1 Then 
     newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 300 
     newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 50 
    ElseIf chartNum = 2 Then 
     newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 50 
     newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 300 
    Else 
     newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 300 
     newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 300 
    End If 

    newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 200 
    newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 200 

當然，與左派，上衣，玩的高度和寬度你自己。

Answer 2

不要忘記設置圖表的寬度或高度之前，使用這樣的：

sr.LockAspectRatio = msoFalse 

這裏sr代表PPApp.ActiveWindow.Selection.ShapeRange

Answer 3

Option Base 1 

Sub CreatePowerPoint() 

     Dim newPowerPoint As PowerPoint.Application 
     Dim activeSlide As PowerPoint.Slide 
     Dim cht As Excel.ChartObject 


     On Error Resume Next 
     Set newPowerPoint = GetObject(, "PowerPoint.Application") 
     On Error GoTo 0 


     If newPowerPoint Is Nothing Then 
      Set newPowerPoint = New PowerPoint.Application 
     End If 

     If newPowerPoint.Presentations.Count = 0 Then 
      newPowerPoint.Presentations.Add 
     End If 

    'Show the PowerPoint 
     newPowerPoint.Visible = True 


      newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank 
      newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count 
      Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count) 

Dim left1(8) 
Dim top1(8) 
left1(1) = 20: top1(1) = 70 
left1(2) = 350: top1(2) = 70 
left1(3) = 20: top1(3) = 300 
left1(4) = 350: top1(4) = 300 
left1(5) = 20: top1(5) = 70 
left1(6) = 350: top1(6) = 70 
left1(7) = 20: top1(7) = 300 
left1(8) = 350: top1(8) = 300 

n = ActiveSheet.ChartObjects.Count 

    nn = WorksheetFunction.RoundUp(n/4, 0) 

    g = 1 

    For pp = 1 To nn 

     p = g 
     t = p + 3 

     x = 1 

     For h = p To t 

      On Error Resume Next 
      ActiveSheet.ChartObjects(h).Select 
      ActiveChart.ChartArea.Copy 
      newPowerPoint.ActiveWindow.ViewType = ppViewSlide 
      activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select 
      Application.CutCopyMode = False 
      With activeSlide.Shapes(x) 
       .Width = 150 
       .Width = 200 
      End With 
      With newPowerPoint.ActiveWindow.Selection.ShapeRange 
       .Left = left1(x) 
       .Top = top1(x) 
      End With 
      x = x + 1 

     Next 
     g = t + 1 



     newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank 
      newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count 
      Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count) 
      newPowerPoint.ActiveWindow.ViewType = ppViewSlide 

Next 


    AppActivate ("Microsoft PowerPoint") 
    Set activeSlide = Nothing 
    Set newPowerPoint = Nothing 

End Sub