投稿/コメントを表示します。

エクセルVBA外部連携講座
Excel の表を貼り付けるには

たかちゃんさんの投稿

(投稿ID: 4957)

47都道府県の性別・年代別の人口比率についてドーナツグラフを作成し、
パワーポイントにスライドに一気に張り付けるものを作成してみました。

このアイデアは以下の参考サイトからですが、コードは全て自力で書き上げました。(^^)
【参考サイト】
https://coconala.com/blogs/1312355/25743

パワーポイントは、色んな所に似たようなプロパティがあって苦労しました。
各プロパティの場所が分かるように、あえて纏めず書いているのでスッキリしていませんが
記念に投稿します。（Excel 2019動作確認済み）
Sub PowerPointTest()
    Dim ppApp As PowerPoint.Application
    Dim ppPrt As PowerPoint.Presentation
    Dim ppSld As PowerPoint.Slide
    Dim ppShape As PowerPoint.Shape 'グラフのタイトルを入力するシェイプ用
    Dim todoufuken As String
    Dim gyo As Long
    
    'Presentation1.pptxを開く（スライドが０枚の状態）
    Set ppApp = New PowerPoint.Application
    Dim path As String
    path = ThisWorkbook.path & "\Presentation1.pptx"
    ppApp.Visible = True
    Set ppPrt = ppApp.Presentations.Open(Filename:=path, ReadOnly:=msoFalse)
    
    
    For gyo = 3 To 49
    
    Worksheets("form").Range("A3").Value = Worksheets("data").Range("A" & gyo).Value
    
    'グラフのタイトル名
    todoufuken = Worksheets("form").Range("B3").Value

    'Excelでグラフを作成する為に範囲を選択、グラフ作成
    Worksheets("form").Range("C1:J3").Select
    Worksheets("form").Shapes.AddChart2(381, xlSunburst).Select

    'グラフのタイトルを非表示
    Worksheets("form").ChartObjects(1).Chart.HasTitle = False
    
    'グラフサイズを調整(ここで調整しないとグラフのデータラベル表示が欠けてしまう)
    Debug.Print Worksheets("form").ChartObjects(1).Chart.PlotArea.Height
    Debug.Print Worksheets("form").ChartObjects(1).Chart.PlotArea.Width
    
    Worksheets("form").ChartObjects(1).Height = 252.262504577637
    Worksheets("form").ChartObjects(1).Width = 407.325050354004
    
    Debug.Print Worksheets("form").ChartObjects(1).Chart.PlotArea.Height
    Debug.Print Worksheets("form").ChartObjects(1).Chart.PlotArea.Width
    
    'グラフをコピー（画像として）
    Worksheets("form").ChartObjects(1).CopyPicture appearance:=xlScreen, Format:=xlPicture

    'グラフを消去（要らないのでグラフは削除しておく）
    Worksheets("form").ChartObjects(1).Delete

    'スライドを作成し、グラフの大きさを調整しスライドの中央に貼り付け
    Dim c As Long    'スライドのカウント用
  
    'スライドの追加
    c = ppPrt.Slides.Count
    Set ppSld = ppPrt.Slides.Add(Index:=c + 1, Layout:=ppLayoutBlank)
    
    'グラフ（シェイプ）の貼り付け
    ppSld.Shapes.Paste
    
    'シェイプの大きさを設定（拡大）
    ppSld.Shapes(1).LockAspectRatio = msoCTrue
    ppSld.Shapes(1).Width = 800
'
    'シェイプの大きさを調査
    Debug.Print ppSld.Shapes(1).Name
    Debug.Print ppSld.Shapes(1).Width
    Debug.Print ppSld.Shapes(1).Height
    
    'スライドの大きさを調査
    Debug.Print ppPrt.PageSetup.SlideWidth
    Debug.Print ppPrt.PageSetup.SlideHeight
    
    'シェイプを中央揃え
    ppSld.Shapes(1).Left = (ppPrt.PageSetup.SlideWidth - ppSld.Shapes(1).Width) / 2
    ppSld.Shapes(1).Top = (ppPrt.PageSetup.SlideHeight - ppSld.Shapes(1).Height) / 2
  
    'グラフのタイトルを入力する為、シェイプを作成し文字を入力
    ppSld.Shapes.AddShape Type:=msoShapeRectangle, Left:=20, Top:=20, Width:=300, Height:=100
    
    Set ppShape = ppSld.Shapes(2)
    ppShape.Fill.Visible = msoFalse
    ppShape.Line.Visible = msoFalse
    ppShape.TextFrame.TextRange.Characters.Font.Size = 60
    ppShape.TextFrame.TextRange.Characters.Font.Color = vbBlack
'   日本語のフォントを設定するので、NameFarEastを使用。"HG 丸ｺﾞｼｯｸ M-PRO"は何故か使えない為明朝体を使用。
    ppShape.TextFrame.TextRange.Font.NameFarEast = "ＭＳ 明朝"
    ppShape.TextFrame.TextRange.Text = todoufuken
    
    Next
    
    ppPrt.Save
    ppPrt.Close
    ppApp.Quit
    
    Set ppShape = Nothing
    Set ppSld = Nothing
    Set ppPrt = Nothing
    Set ppApp = Nothing

End Sub



2020/12/24 12:04