【VBA】Excelグラフを編集可能なオブジェクト形式でPPTに貼り付ける（ファイルサイズを増やさずに）

ExcelグラフをPPTファイルに貼り付ける時、図の形式で貼り付けを行うケースが多いと思いますが、『PPTファイル上で編集を行いたいので、編集可能な状態でPPT上にグラフオブジェクトを配置してほしい。ファイル容量は、出来るだけ大きくなりすぎないようにしてほしい』という要望を受け、対応策を検討する事となりました。

※図として貼り付けた場合

※オブジェクトとして貼り付けた場合

グラフオブジェクトの貼り付け

グラフオブジェクトとしての貼り付け方法は、PPTグラフ貼り付けオプションの「元の書式を保持しブックを埋め込む」を指定します。※リンク貼り付けだと元の書式を再現できないケースがあったのと、別ファイルへのリンクは貼る事は避けたいため、、

VBAでの記述コードは以下のようになります。

Sub PPTグラフ貼り付け実行_通常ver()

Dim PPT As PowerPoint.Application
Dim PRS As PowerPoint.Presentation
Dim ExFile As Workbook

Dim shc As Variant          'シェイプ数のカウント用フラグ

Const V_position = 2.5      'グラフの縦方向貼り付け位置
Const H_position = 6        'グラフの横方向貼り付け位置
Const P2CM = 1 / 72 * 2.54  'この係数で上記を割る事で、PPT上の縦横貼り付け位置で座標を指定出来る

Dim SET_PATH As Variant
Dim File_Name As Variant
    
Application.ScreenUpdating = False
Application.DisplayAlerts = False
           
File_Name = Application.GetOpenFilename("Excelファイル (*.xls*), *.xls*", , "グラフファイルを選択")
    
If File_Name = False Then
    End
End If
        
SET_PATH = "【グラフを貼り付けるPPTファイルのフルパスを指定】"　'←作業内容に応じて変更
Set ExFile = Workbooks.Open(File_Name, ReadOnly:=False)

'PPT編集の前処理　---------------
Set PPT = CreateObject("PowerPoint.Application")
PPT.Visible = True
PPT.WindowState = ppWindowMinimized
PPT.Presentations.Open SET_PATH, ReadOnly:=True
Set PPT = GetObject(, "Powerpoint.Application")
Set PRS = PPT.ActivePresentation
'----------------------------------------
    
Application.ScreenUpdating = True

ExFile.Activate
Worksheets("【シート名】").Activate　'←作業内容に応じて変更
ActiveSheet.ChartObjects(1).Copy

With PRS.Slides(1)
    .Select

    '貼り付け前のシート数取得　---------------
    shc = .Shapes.Count

    'ExecuteMsoコマンドでグラフを貼り付け　---------------
    PPT.CommandBars.ExecuteMso "PasteExcelChartSourceFormatting"
    
    '貼り付け前の枚数が変わるまでwait　---------------
    Do While shc = .Shapes.Count
        DoEvents
    Loop

    'グラフ貼り付け位置の指定　---------------
    .Shapes(.Shapes.Count).Top = V_position / P2CM
    .Shapes(.Shapes.Count).Left = H_position / P2CM

End With

Application.ScreenUpdating = True

End Sub

※上記コードを実行するためには、事前にVBAツールの参照設定を変更しておく必要があります。

これでPPTファイルにグラフオブジェクトとして貼り付ける事は出来るようになりますが、埋め込み形式でグラフを大量に貼り付けてしまうと、PPTファイルの容量が膨大な事になってしまいます。。
（実務では、当初PPTファイルの容量が200MBを超える事態となってしまいました（汗）

ファイル容量の削減策

PPTファイル容量を圧縮するために、
【シートを別ブックに複製し、複製ファイルのグラフをコピーしてPPTに貼り付け。
貼り付け後、複製ファイルを保存せずに閉じる】
という一工程を加えました。

上記イメージ図の概念を反映後のVBAコードは、以下のようになります。

Sub PPTグラフ貼り付け実行_リンク切りver()

Dim PPT As PowerPoint.Application
Dim PRS As PowerPoint.Presentation
Dim ExFile As Workbook
Dim ExFile2 As Workbook

Dim shc As Variant          'シェイプ数のカウント用フラグ
        
Const V_position = 2.5      'グラフの縦方向貼り付け位置
Const H_position = 6        'グラフの横方向貼り付け位置
Const P2CM = 1 / 72 * 2.54  'この係数で上記を割る事で、PPT上の縦横貼り付け位置で座標を指定出来る

Dim SET_PATH As Variant
Dim File_Name As Variant

Application.ScreenUpdating = False
Application.DisplayAlerts = False
        
File_Name = Application.GetOpenFilename("Excelファイル (*.xls*), *.xls*", , "グラフファイルを選択")
    
If File_Name = False Then
    End
End If
        
SET_PATH = "【グラフを貼り付けるPPTファイルのフルパスを指定】"　'←作業内容に応じて変更      
Set ExFile = Workbooks.Open(File_Name, ReadOnly:=False)
    
'PPT編集の前処理　---------------
Set PPT = CreateObject("PowerPoint.Application")
PPT.Visible = True
PPT.WindowState = ppWindowMinimized
PPT.Presentations.Open SET_PATH, ReadOnly:=True
Set PPT = GetObject(, "Powerpoint.Application")
Set PRS = PPT.ActivePresentation
'----------------------------------------
    
Application.ScreenUpdating = True

ExFile.Activate
With Worksheets("【シート名】").Activate　'←作業内容に応じて変更
    .Activate

    .Select
    .Copy
    Set ExFile2 = ActiveWorkbook
    ActiveSheet.ChartObjects(1).Copy
End With

With PRS.Slides(1)
    .Select

    '貼り付け前のシート数取得　---------------
    shc = .Shapes.Count

    'ExecuteMsoコマンドでグラフを貼り付け　---------------
    PPT.CommandBars.ExecuteMso "PasteExcelChartSourceFormatting"
    
    '貼り付け前の枚数が変わるまでwait　---------------
    Do While shc = .Shapes.Count
        DoEvents
    Loop

    'グラフ貼り付け位置の指定　---------------
    .Shapes(.Shapes.Count).Top = V_position / P2CM
    .Shapes(.Shapes.Count).Left = H_position / P2CM

    ExFile2.Close
    Set ExFile2 = Nothing

End With

Application.ScreenUpdating = True

End Sub

※ExFileのグラフシートをExFile2として別ファイルにコピーし、そこからグラフ貼り付け、という導線になります。

結果、当初200MBを超えてしまったファイル容量を、1MB程度まで容量圧縮する事が出来るようになり、
【ファイル容量の増加を抑え、PPT上で編集可能な形式でグラフオブジェクトを配置する】
という当初の希望を実現するファイルを作成する事が出来ました。

まとめ

複製ファイルからオブジェクトをコピーする、という解消手段を取りましたが、リンク貼りしてからリンク解除する、というような別の解消手段もあるかもしれません。
また元ファイルからのリンクが切れる事により、ファイル容量が減る、ファイル管理の利便性・安定性が上がるなどのメリットが期待できますが、元データの参照などがPPT上からは出来なくなるため、ユーザーに対して、実現出来る事／出来ない事の事前説明をしておくことが望ましいと思います。