VBA - エクセルチャートを同じスライド上のパワーポイントにエクスポート

Question

Sub Export_Allcahrts_ppt() 

Dim mypowerpoint As PowerPoint.Application 

Set mypowerpoint = New PowerPoint.Application 

mypowerpoint.Visible = msoTrue 

Dim mypowerpoint_pres As PowerPoint.Presentation 

Set mypowerpoint_pres = mypowerpoint.Presentations.Add 

Dim myslide As PowerPoint.Slide 

Set myslide = mypowerpoint_pres.Slides.Add(1, ppLayoutBlank) 

Dim mychart As ChartObject 

Dim j As Long 
j = 0 
For Each mychart In Sheet1.ChartObjects 
j = j + 1 
Next 


For Each mychart In Sheet1.ChartObjects 

mychart.Copy 

myslide.Shapes.PasteSpecial ppPasteBitmap 

myslide.Shapes(1).Top = 100 

myslide.Shapes(1).Height = 200 

myslide.Shapes(1).Left = 30 

If mypowerpoint_pres.Slides.Count < j Then 

Set myslide = mypowerpoint_pres.Slides.Add(mypowerpoint_pres.Slides.Count + 1, ppLayoutBlank) 

Else 

Exit Sub 

End If 

Next 


End Sub 

Answer 1

まず、jを得るためにループする必要はありません。ちょうど使用する

j = Sheet1.ChartObjects.Count 

でも、jはまったく必要ありません。あなたのコードが行うことは、スライドの数がこれまでにコピーされたチャートの数とまだ等しくない場合は、新しい各チャートの新しいスライドを挿入することです。

これを少し再整理して合理化したコードを試してみてください。私はそれをテストしていないが、私は構文を変更したとは思わない。

Sub Export_Allcahrts_ppt() 
    Dim mypowerpoint As PowerPoint.Application 
    Dim mypowerpoint_pres As PowerPoint.Presentation 
    Dim myslide As PowerPoint.Slide 
    Dim mychart As ChartObject 
    Dim j As Long 

    Set mypowerpoint = New PowerPoint.Application 
    mypowerpoint.Visible = msoTrue 

    Set mypowerpoint_pres = mypowerpoint.Presentations.Add 

    Set myslide = mypowerpoint_pres.Slides.Add(1, ppLayoutBlank) 

    j = Sheet1.ChartObjects.Count 

    For Each mychart In Sheet1.ChartObjects 
    mychart.Copy 
    myslide.Shapes.PasteSpecial ppPasteBitmap 

    With myslide.Shapes(myslide.Shapes.Count) 
     .Top = 100 
     .Height = 200 
     .Left = 30 
    End With 
    Next 

End Sub