[ExcelVBA]ExcelグラフをPowerPointへ任意の位置・大きさで貼り付ける

[ExcelVBA]ExcelグラフをPowerPointへ任意の位置・大きさで貼り付ける

Excelで作った複数のグラフや表を、ひとつずつ貼付先のPowerPointのシートの位置・貼付ける大きさを指定しておいてから、コピペするコードです。


はじめに

本記事は、こちらの派生記事です。

前書いたやつは、Excel側のオブジェクトと貼り付け先PPTのスライド番号を指定して、位置と大きさは一定でした。

でも、「このグラフは1番めのスライドの左上へ大きめに」「こっちの表を同じスライドの右下へ小さめに」「このグラフは2番めのスライドにドンと大きく」…、みたいな感じでひとつずつ位置や大きさを細かく指定して貼り付けたいというご要望がありました。言われてみればそういう使い方のほうが汎用的ですよね！

というわけで作ったコードを汎用的にしてまとめました。

仕様

161114-1 161114-2

Excelにあるグラフとか表を（グラフ名の調べ方は前述記事にありますので、間違えずに指定してください）、

161114-3 161114-4

このようにPPTの好きな場所へ好きな大きさで貼り付けます。貼り付け先のPPTは、指定されているスライドがすべて存在していて、既に開いているのが条件です。

大きさについては、縦横比固定にしてあるので、横幅だけ指定すれば縦幅はそれに連動して自動で決まる、という感じです。

前回はそれぞれの要素を配列を使って指定したのですが、ここ最近クラスモジュールがわかるようになってきて、これもクラスを使ったほうが断然やりやすいじゃん！　と思って、効率的なコードを目指してやってみました。

参考

こまけぇことはどうでもいいんだよ！　という人は一番下のコードだけみてくださいw

方法1

最初に考えた形。

Class1

Public Name As Object 'オブジェクト名
Public SldNmb As Integer 'スライド番号
Public Top As Integer '上からの位置
Public Left As Integer '左からの位置
Public Width As Integer '横幅
Public Odr As Integer '順番 0→最前面 1→最背面

Property Get Self() As Class1
  Set Self = Me '自己参照
End Property

Publicで宣言してかんたんに使っちゃいます。

Module1

Sub CopyToPPT()
  'コレクション生成
  Dim Objs As Collection
  Set Objs = New Collection
  
  'シート名を変数へセット
  Dim s1 As Worksheet: Set s1 = Sheets("Sheet1")
  Dim s2 As Worksheet: Set s2 = Sheets("Sheet2")
  
  '各要素をコレクションにセット
  'ひとつめ
  With New Class1 'インスタンス生成
    Set .Name = s1.ChartObjects("グラフ 1") 'オブジェクト名
    .SldNmb = 1 'スライド番号
    .Top = 20 '上からの位置
    .Left = 20 '左からの位置
    .Width = 500 '横幅
    .Odr = 0 '順番 0→最前面 1→最背面
    Objs.Add .Self 'Objsコレクションに追加
  End With '破棄

  'ふたつめ
  With New Class1
    Set .Name = s1.Range("B3:H7")
    .SldNmb = 2
    .Top = 50
    .Left = 10
    .Width = 600
    .Odr = 0
    Objs.Add .Self
  End With

  'みっつめ
  With New Class1
    Set .Name = s2.ChartObjects("グラフ 2")
    .SldNmb = 1
    .Top = 250
    .Left = 350
    .Width = 600
    .Odr = 1
    Objs.Add .Self
  End With

  'よっつめ
  With New Class1
    Set .Name = s2.Range("B3:E12")
    .SldNmb = 2
    .Top = 200
    .Left = 550
    .Width = 400
    .Odr = 1
    Objs.Add .Self
  End With

  'PPTに各要素を貼り付け、後処理（ここは共通なので、のちほど）
End Sub

動作はするけど、長すぎ。ひとつのオブジェクトにこんなに行数を使ってられっか！！

方法2

Class1

Public Name As Object 'オブジェクト名
Public SldNmb As Integer 'スライド番号
Public Top As Integer '上からの位置
Public Left As Integer '左からの位置
Public Width As Integer '横幅
Public Odr As Integer '順番 0→最前面 1→最背面

Property Get Self() As Class1
  Set Self = Me '自己参照
End Property

Sub SetProp(NewName As Object, NewSldNmb As Integer, NewTop As Integer, _
            NewLeft As Integer, NewWidth As Integer, NewOdr As Integer)
  Set Name = NewName 'オブジェクト名
  SldNmb = NewSldNmb 'スライド番号
  Top = NewTop '上からの位置
  Left = NewLeft '左からの位置
  Width = NewWidth '横幅
  Odr = NewOdr '順番 0→最前面 1→最背面
  Objs.Add Self 'Objsコレクションに追加
End Sub

プロパティをセットするサブルーチンをクラスに書いちゃう。

Module1

Public Objs As Collection 'コレクション宣言

Sub CopyToPPT()
  'コレクション生成
  Set Objs = New Collection
  
  'シート名を変数へセット
  Dim s1 As Worksheet: Set s1 = Sheets("Sheet1")
  Dim s2 As Worksheet: Set s2 = Sheets("Sheet2")
  
  '各要素をコレクションにセット
  'オブジェクト名, スライド番号, 上からの位置, 左からの位置, 横幅, 順番(0→最前面 1→最背面) の順で
  'ひとつめ
  With New Class1 'インスタンス生成
    .SetProp s1.ChartObjects("グラフ 1"), 1, 20, 20, 500, 0 'プロパティ設定
  End With '破棄

  'ふたつめ
  With New Class1
    .SetProp s1.Range("B3:H7"), 2, 50, 10, 600, 0
  End With

  'みっつめ
  With New Class1
    .SetProp s2.ChartObjects("グラフ 2"), 1, 250, 350, 600, 1
  End With

  'よっつめ
  With New Class1
    .SetProp s2.Range("B3:E12"), 2, 200, 550, 400, 1
  End With

  'PPTに各要素を貼り付け、後処理（ここは共通なので、のちほど）
End Sub

セットの記述がだいぶ短くなりました。モジュールを超えて使うのでコレクションの宣言はPublicに。この方式なら持たせたいプロパティが増えても行数が増えないですね。

でも、1行で！　プロパティのセットは1行で書きたい！！　((└(:3」┌)┘))

方法3

どうしてもプロパティセットを1行にしたかった結果。

Class1

Public Name As Object 'オブジェクト名
Public SldNmb As Integer 'スライド番号
Public Top As Integer '上からの位置
Public Left As Integer '左からの位置
Public Width As Integer '横幅
Public Odr As Integer '順番 0→最前面 1→最背面

Property Get Self() As Class1
  Set Self = Me '自己参照
End Property

Module1

Private Objs As Collection 'コレクション宣言

Sub CopyToPPT()
  'コレクション生成
  Set Objs = New Collection
  
  'シート名を変数へセット
  Dim s1 As Worksheet: Set s1 = Sheets("Sheet1")
  Dim s2 As Worksheet: Set s2 = Sheets("Sheet2")
  
  '各要素をコレクションにセット
  'オブジェクト名, スライド番号, 上からの位置, 左からの位置, 横幅, 順番(0→最前面 1→最背面) の順で
  Call SetProp(s1.ChartObjects("グラフ 1"), 1, 20, 20, 500, 0) 'ひとつめ
  Call SetProp(s1.Range("B3:H7"), 2, 50, 10, 600, 0) 'ふたつめ
  Call SetProp(s2.ChartObjects("グラフ 2"), 1, 250, 350, 600, 1) 'みっつめ
  Call SetProp(s2.Range("B3:E12"), 2, 200, 550, 400, 1) 'よっつめ

  'PPTに各要素を貼り付け、後処理（ここは共通なので、のちほど）
End Sub

Sub SetProp(NewName As Object, NewSldNmb As Integer, NewTop As Integer, _
            NewLeft As Integer, NewWidth As Integer, NewOdr As Integer)
  With New Class1 'インスタンス生成
    Set .Name = NewName 'オブジェクト名
    .SldNmb = NewSldNmb 'スライド番号
    .Top = NewTop '上からの位置
    .Left = NewLeft '左からの位置
    .Width = NewWidth '横幅
    .Odr = NewOdr '順番 0→最前面 1→最背面
    Objs.Add .Self 'Objsコレクションに追加
  End With '破棄
End Sub

インスタンスの生成とプロパティをセットするサブルーチンを、標準モジュールのほうに書きました。これだとメインのコードで要素のセットが1行で済むので、コピペするオブジェクトがたくさんあっても書きやすいと思いました。

最終コード

というわけで、3番めの方法でPPTへのコピペまで含めたコードがこちら。

Class1

Public Name As Object 'オブジェクト名
Public SldNmb As Integer 'スライド番号
Public Top As Integer '上からの位置
Public Left As Integer '左からの位置
Public Width As Integer '横幅
Public Odr As Integer '順番 0→最前面 1→最背面

Property Get Self() As Class1
  Set Self = Me '自己参照
End Property

Module1

Private Objs As Collection 'コレクション宣言

Sub CopyToPPT()
  'コレクション生成
  Set Objs = New Collection
  
  'シート名を変数へセット
  Dim s1 As Worksheet: Set s1 = Sheets("Sheet1")
  Dim s2 As Worksheet: Set s2 = Sheets("Sheet2")
  
  '各要素をコレクションにセット
  'オブジェクト名, スライド番号, 上からの位置, 左からの位置, 横幅, 順番(0→最前面 1→最背面) の順で
  Call SetProp(s1.ChartObjects("グラフ 1"), 1, 20, 20, 500, 0) 'ひとつめ
  Call SetProp(s1.Range("B3:H7"), 2, 50, 10, 600, 0) 'ふたつめ
  Call SetProp(s2.ChartObjects("グラフ 2"), 1, 250, 350, 600, 1) 'みっつめ
  Call SetProp(s2.Range("B3:E12"), 2, 200, 550, 400, 1) 'よっつめ

  'PPTの準備
  On Error GoTo ERROR_HANDLER
  Dim ppApp As Object: Set ppApp = CreateObject("PowerPoint.Application") 'PPTアプリ
  Dim pp As Object: Set pp = ppApp.ActivePresentation 'PPTプレゼン
  Dim ppSld As Object 'PPTスライド
  
  Dim Obj As Class1
  For Each Obj In Objs 'Objsコレクションをループ
    Obj.Name.CopyPicture xlScreen, xlPicture '指定オブジェクトをクリップボードにコピー
    Set ppSld = pp.Slides(Obj.SldNmb) 'PowerPointスライド指定
    ppSld.Shapes.Paste '貼り付け

    '位置・サイズを補正
    With ppSld.Shapes(ppSld.Shapes.Count) '最終シェイプを指定
      .LockAspectRatio = msoTrue '縦横比固定
      .Top = Obj.Top '上からの位置
      .Left = Obj.Left '左からの位置
      .Width = Obj.Width '横幅
      .ZOrder Obj.Odr '移動
    End With
  Next

TERMINATE:
  On Error GoTo 0
  Set ppApp = Nothing
  Set pp = Nothing
  Set ppSld = Nothing
  Set Objs = New Collection
  Exit Sub

ERROR_HANDLER:
  MsgBox Err.Description, vbCritical
  Resume TERMINATE
End Sub

Sub SetProp(NewName As Object, NewSldNmb As Integer, NewTop As Integer, _
            NewLeft As Integer, NewWidth As Integer, NewOdr As Integer)
  With New Class1 'インスタンス生成
    Set .Name = NewName 'オブジェクト名
    .SldNmb = NewSldNmb 'スライド番号
    .Top = NewTop '上からの位置
    .Left = NewLeft '左からの位置
    .Width = NewWidth '横幅
    .Odr = NewOdr '順番 0→最前面 1→最背面
    Objs.Add .Self 'Objsコレクションに追加
  End With '破棄
End Sub

コピペしたいオブジェクトを増やしたい場合は16行目以降に追加してください。クラスを使って自分でプロパティを作っちゃえばコードが読みやすいし、配列のときと違って「全部で何個」というのを最初に指定しなくて良いので楽ですね。

追記：更に改コード

この記事を読んで、thomさんがこんな記事を書いてくださいました。

・・・

・・・

神　か　！　！　！

かかか神が降臨なさったー！Σ（ﾟдﾟlll）　なんていうか、うっとりしてしまう綺麗なコードですね…(*´ω`*)　そんなthom神のお導きにより、スマートになったコードがこちら。

Class1

Public Name As Object 'オブジェクト名
Public SldNmb As Integer 'スライド番号
Public Top As Integer '上からの位置
Public Left As Integer '左からの位置
Public Width As Integer '横幅
Public Odr As Integer '順番

Property Get Self() As Class1
  Set Self = Me '自己参照
End Property

Function CreateNew(NewName As Object, NewSldNmb As Integer, NewTop As Integer, _
                   NewLeft As Integer, NewWidth As Integer, NewOdr As Integer) As Class1
  With New Class1
    Set .Name = NewName 'オブジェクト名
    .SldNmb = NewSldNmb 'スライド番号
    .Top = NewTop '上からの位置
    .Left = NewLeft '左からの位置
    .Width = NewWidth '横幅
    .Odr = NewOdr '順番
    Set CreateNew = .Self '作成したインスタンスを返す
  End With
End Function

クラスでFounctionを使って自身のインスタンスを返すとか…。。私には到底思いつきませんでしたヽ(゜´Д｀)ノ゜。

Module1

Sub CopyToPPT()
  'コレクション生成
  Dim Objs As Collection: Set Objs = New Collection
  
  'シート名を変数へセット
  Dim s1 As Worksheet: Set s1 = Sheets("Sheet1")
  Dim s2 As Worksheet: Set s2 = Sheets("Sheet2")

  '各要素をコレクションにセット
  'オブジェクト名, スライド番号, 上からの位置, 左からの位置, 横幅, 順番(0→最前面 1→最背面) の順で
  With New Class1
    Objs.Add .CreateNew(s1.ChartObjects("グラフ 1"), 1, 20, 20, 500, 0) 'ひとつめ
    Objs.Add .CreateNew(s1.Range("B3:H7"), 2, 50, 10, 600, 0) 'ふたつめ
    Objs.Add .CreateNew(s2.ChartObjects("グラフ 2"), 1, 250, 350, 600, 1) 'みっつめ
    Objs.Add .CreateNew(s2.Range("B3:E12"), 2, 200, 550, 400, 1) 'よっつめ
  End With

  'PPTの準備
  On Error GoTo ERROR_HANDLER
  Dim ppApp As Object: Set ppApp = CreateObject("PowerPoint.Application") 'PPTアプリ
  Dim pp As Object: Set pp = ppApp.ActivePresentation 'PPTプレゼン
  Dim ppSld As Object 'PPTスライド
  
  Dim Obj As Class1
  For Each Obj In Objs 'Objsコレクションをループ
    Obj.Name.CopyPicture xlScreen, xlPicture '指定オブジェクトをクリップボードにコピー
    Set ppSld = pp.Slides(Obj.SldNmb) 'PowerPointスライド指定
    ppSld.Shapes.Paste '貼り付け

    '位置・サイズを補正
    With ppSld.Shapes(ppSld.Shapes.Count) '最終シェイプを指定
      .LockAspectRatio = msoTrue '縦横比固定
      .Top = Obj.Top '上からの位置
      .Left = Obj.Left '左からの位置
      .Width = Obj.Width '横幅
      .ZOrder Obj.Odr '移動
    End With
  Next

TERMINATE:
  On Error GoTo 0
  Set ppApp = Nothing
  Set pp = Nothing
  Set ppSld = Nothing
  Exit Sub

ERROR_HANDLER:
  MsgBox Err.Description, vbCritical
  Resume TERMINATE
End Sub

どうですかこのスマートなコード！！（興奮）

コピペしたいオブジェクトを増やしたい場合は15行目以降に追加です。もうthom神には感謝してもし足りません。ありがとうございます！！！

公開日：2016/11/14
更新日：2016/11/16

ExcelVBAに興味をお持ちの方は、こちらの記事もどうぞ！

書籍を執筆しています。

はてブ Pocket feedly

9件のコメント

  1. adachi より:
    2017年12月2日 9:14 AM

    こちらのサイト（追記：更に改コード）を参考にグラフをパワーポイントへ貼り付けることができました。大変助かりました。
    それで厚かましいお願いですが、vbaど素人でして、わからないことがあり、お手すきの時に回答をいただけたら幸いです。一つのエクセルファイルにあるグラフを一つのスライドに貼ることはできたのですが、複数のエクセルファイルのものを新しいスライドを追加して、同じ処理をする、とういうことができません。なぜか新しいスライドを追加という簡単なことさえできません。２０以上のエクセルファイルを一つのフォルダに入れ、ユーザーフォームでフォルダを選択すると、その中のエクセルファイルに対して連続で処理をする。という方法できたらと思います。フォルダ選択やファイルの呼び出しのコードは書けてます。よろしくお願いいたします。

    返信
    • *you より:
      2017年12月4日 6:04 AM

      adachiさん、コメントありがとうございます。情報が足りないので確認させてください。

      まずは、貼付元のxlsxファイルは20以上とのことですが、コピーしたいオブジェクトは少なくとも20以上あるということですよね？　それらをすべてファイル名、シート名、オブジェクト名まで指定して実行しますか？　この方法は、あまりに数が多いとメンテナンスが面倒です。コピー元が少し変わっただけで修正しなければなりませんし…。

      そういった場合、VBAでガッチガチに1つずつ位置や大きさまで指定して作るんじゃなくて、とりあえずざっくりとpptxに貼付けちゃった後、あとはそちらで要らないものを削除したり、位置や大きさを微調整したり、というほうが楽だと思います。

      たとえば、コピーしたいものを「グラフ」だけで限定できるなら、フォルダ内の複数xlsxファイルについて、すべてのシート内のすべてのグラフオブジェクトをpptxスライドに貼り付ける、という仕様にするとか。これならクラスモジュールをつくらなくてもよいですし、コードもシンプルです。xlsx側のグラフの数や名称が変わっても問題ありません。そういった感じでいかがですか？

      追記：せっかくなのでそちらのコードも書きました。

      なお、新規スライドを挿入するタイミングはどこでしょうか？　xlsxファイルごと、シートごと、1つのグラフごとあたりが考えられます。1スライドに複数のグラフが貼り付けられる場合、少しずつ右下にズレて貼り付けられていく形になると思います。

      また、貼付先のpptxファイルは、既存のものを開いておいて使うのか、新規作成するかも教えてください。

  2. adachi より:
    2017年12月5日 9:23 PM

    お返事ありがとうございます。少ない情報でお聞きしてしまい申し訳ありません。

    家でこちらのサイトに書き込みをしているため、自分が会社で書いたコードをお見せできなく、足りない点があるかと思いますが、なるべく状況を詳細に書きます。

    貼付元はエクセルファイルで、ファイルが２０個あります。(名前は番号で1.xlsx, 2.xlsx, 3.xlsx〜20.xlsx)
    どのファイルも同じ構成です。
    １シート目に図が数個あり、そのうちの図２という番号のものを既存のパワポの左上に貼ります。
    ２シート目にグラフが６個あり、そのうちのグラフ３という番号のものを同じスライドの左下、グラフ４を右上、グラフ５を右下に貼ります。
    どのエクセルファイルも同じフォームで、貼りたいグラフや図の番号も同じです。
    やりたいことは、1.xlsxの図やグラフを既存のパワポの１ページ目に貼り、2.xlsxの同じ番号の図やグラフを2ページ目に貼るといった要領でして、既存のパワポ（会社名のロゴが入ったスライド１ページ）に、スライドを追加しながら、２０ページの１ファイルを作成したいです。
    なお、毎回エクセルのファイルの名前、ファイル数は変わりますが、図番やグラフの番号は変わりません。図の大きさは変わったりしますが、こちらのサイト（追記：更に改コード）を参考にしましたところ、1.xlsxがパワポ１ページ目にきれいに貼れました。
    しかし、２ページ目以降のコードが書けません。
    エクセルVBAで作成してます。

    ‘各要素をコレクションにセット
    ‘オブジェクト名, スライド番号, 上からの位置, 左からの位置, 横幅, 順番(0→最前面 1→最背面) の順で
    のところで、スライド番号１と指定しているせいか、１ページしか作成されません。。。
    変数のこともよく分かってなく、
    For Each book in Workbooks
    Next
    と入れてもうまくいきません。。かなり時間をかけてもがいている状況でして、厚かましいですが、具体的な繰り返し処理のコードを書いていただけると助かります。

    お忙しいところ申し訳ないですが、よろしくお願いいたします。

    返信
    • *you より:
      2017年12月6日 12:10 PM

      adachiさん、ご回答ありがとうございます。思っていたよりも固定部分が多そうですね。その内容ならクラスモジュールを使わなくてもいいと思います。標準モジュールのみで、以下のコードをお試しください。

      Sub copyToPPT()
  'フォルダ選択
  With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = "C:\" '初期フォルダ指定
    If .Show = True Then
      Dim tgtPath As String: tgtPath = .SelectedItems(1) & "\" 'フォルダパスを取得
    Else
      Exit Sub 'キャンセルを押されたら終了
    End If
  End With
  
  'フォルダ内のxlsxファイルをコレクションに格納
  Dim XlsxList As Collection: Set XlsxList = New Collection
  Dim buff As String: buff = Dir(tgtPath & "*.xlsx")
  Dim hasFile As Boolean
  Do While buff <> ""
    XlsxList.Add buff
    buff = Dir()
    hasFile = True
  Loop
  If hasFile = False Then '存在チェック
    MsgBox "指定のフォルダにxlsxファイルが存在しません"
    Exit Sub
  End If
  
  'PPTの準備
  Dim ppApp As Object: Set ppApp = CreateObject("PowerPoint.Application") 'PPTアプリ
  Dim pp As Object: Set pp = ppApp.ActivePresentation 'PPTプレゼン
  
  Application.ScreenUpdating = False '画面描画OFF
  
  Dim addSld As Boolean 'スライド追加フラグ（1回目は存在するのでFalse）
  Dim bookName As Variant 'ループ用変数
  For Each bookName In XlsxList 'XlsxListコレクションをループ
    Dim wb As Workbook: Set wb = Workbooks.Open(tgtPath & bookName) 'ブックを開く
    
    'オブジェクトのコピペ（ppt変数, オブジェクト名, 上からの位置, 左からの位置, 横幅 の順で）
    Call pasteObjs(pp, wb.Sheets("Sheet1").Shapes("図2"), 50, 50, 100, addSld) 'スライド追加フラグはここだけ
    Call pasteObjs(pp, wb.Sheets("Sheet2").ChartObjects("グラフ3"), 300, 50, 400)
    Call pasteObjs(pp, wb.Sheets("Sheet2").ChartObjects("グラフ4"), 50, 500, 400)
    Call pasteObjs(pp, wb.Sheets("Sheet2").ChartObjects("グラフ5"), 300, 500, 400)
    
    'ブック名を挿入
    pp.Slides(pp.Slides.Count).Shapes.AddTextbox( _
      Orientation:=msoTextOrientationHorizontal, _
      left:=0, _
      top:=0, _
      width:=200, _
      Height:=50) _
      .TextFrame.TextRange.Text = bookName
    
    wb.Close 'ブックを閉じる
    addSld = True 'ループ2回目以降はスライド追加のためフラグを立てる
  Next
  
  Application.ScreenUpdating = True '画面描画ON
  
End Sub

Sub pasteObjs(pp As Object, obj As Object, top As Integer, left As Integer, width As Integer, Optional addSld As Boolean = False)
  'オブジェクト貼り付け用プロシージャ
  
  obj.CopyPicture xlScreen, xlPicture '指定オブジェクトをクリップボードにコピー
  Dim ppSld As Object
  If addSld = True Then 'スライド追加判定
    Set ppSld = pp.Slides.Add(Index:=pp.Slides.Count + 1, Layout:=12) 'スライドを追加して指定（定数12=ppLayoutBlank）
  Else
    Set ppSld = pp.Slides(pp.Slides.Count) '最終スライドを指定
  End If
  ppSld.Shapes.Paste '貼り付け

  '位置・サイズを補正
  With ppSld.Shapes(ppSld.Shapes.Count) '最終シェイプを指定
    .LockAspectRatio = msoTrue '縦横比固定
    .top = top '上からの位置
    .left = left '左からの位置
    .width = width '横幅
  End With
End Sub

      プロシージャが2つに分割されていますが、実行するのはcopyToPPTのほうです。私の想像で書いているところもあるので、環境に合わせて修正してください。

      フォルダの中身をコレクションに格納した順番でスライドを追加していく仕様になっています。そのため必ずしも1.xlsxが1枚目、2.xlsxが2枚目…のようになる保証がありません。たとえばファイル名の連番に抜けがあったらスライド番号はズレます。ファイル名とスライド番号を完全に一致させたいのならば、もうちょっと違う方法になるかと思います。

      一応、どのブックのものかわかるようにコピー元のブック名をテキストボックスへ記述するようにしてあります。不要ならば削除してください。

      また、エラー処理までは書いていないので、そのあたりもご随意にカスタマイズしてください。

  3. adachi より:
    2017年12月6日 8:40 PM

    *youさま

    この度は至れり尽くせりのコードを書いてくださりありがとうございます。完璧でした。コピー元のブックがをテキストボックスへ記されるなど、細やかな配慮がされていて、そして昨日の今日に書いてくださって、本当に頭が下がります。
    おかげさまで苦しい状況から脱する事ができました。
    対価をお支払いしたいのですが、執筆されている本がAccess系で現在のところ業務で使う予定がなく、、
    今後wordpressやvbaの本を出版された際には必ずや購入させていただきます。もしくはこちらのサイトに貼られているアフィリエイトから物品を購入させていただきます。
    この度は食い逃げのような形で申し訳ありません。
    ますますのご活躍をお祈り申し上げます。

    返信
    • *you より:
      2017年12月7日 4:06 PM

      それはよかったです！　だいぶ長い間お悩みだったようで、トンネル抜けるお手伝いができて光栄です。元々記事として書いてあったコードの応用なのと、adachiさんが丁寧に説明してくださったから早めに書けたんだと思います！

      お気になさらなくて全然大丈夫なのですが、ExcelVBA初心者向けというテーマの書籍も書いてみたいと編集さんとお話はさせていただいているので、もし企画が通って出すことができたら、そのときはぜひ、お願いできたら嬉しく思いますw

  4. adachi より:
    2017年12月7日 8:29 PM

    *youさま

    お返事ありがとうございます。
    ExcelVBA初心者向けの本が出版された際はぜひ購入したいと思います。やはり一般事務しかやってこなかった者にとっては挫折しやすい分野かと思います。理解してないので、なかなか壁を超えることができません。何をやってもいちいちつまづいてしまいます。本で噛み砕いて説明してくださるとありがたいです。

    そして、度々で申し訳ありません、おひとつお伺いしたいのですが、パワーポイントにテキストを入れる際、フォント名とサイズを指定する場合、どのように書けばいいのでしょうか。

    *youさまが書いてくださったコード”’ブック名を挿入”を応用して、一番下の２行を追記しましたが、うまくいきませんでした。。

    ‘テキストを挿入
    pp.Slides(pp.Slides.Count).Shapes.AddTextbox( _
    Orientation:=msoTextOrientationHorizontal, _
    left:=0, _
    top:=0, _
    width:=200, _
    Height:=50) _
    .TextFrame.TextRange.Text = “サンプル”
    .TextFrame.TextRange.Font.Name=”Meiryo UI”
    .TextFrame.TextRange.Font.Size=20

    全く急いでおりませんので、お時間に余裕がある時にお返事をいただけましたら幸いです。

    返信
    • *you より:
      2017年12月8日 12:38 PM

      adachiさん

      コードの基礎的な話になってしまいますが、 _というのは、長い1行を改行して表現するためのものです。

      pp.Slides(pp.Slides.Count).Shapes.AddTextbox( _
  Orientation:=msoTextOrientationHorizontal, _
  left:=0, _
  top:=0, _
  width:=200, _
  Height:=50) _
  .TextFrame.TextRange.Text = "サンプル"

      見た目がわかりやすいように改行してあるだけで、この部分はつながった1行なんです。コードは基本的にオブジェクト.プロパティのようにドットで繋げて書くので、下2行のこの部分、

      .TextFrame.TextRange.Font.Name = "Meiryo UI"
.TextFrame.TextRange.Font.Size = 20

      ここは、オブジェクトを指定していない、宙ぶらりんのような状態になってしまっているのです。今回のように、挿入したテキストボックスに対して2つ以上の設定を加えたいのなら、以下のように書くといいんじゃないでしょうか。

      'テキストを挿入
pp.Slides(pp.Slides.Count).Shapes.AddTextbox( _
  Orientation:=msoTextOrientationHorizontal, _
  left:=0, _
  top:=0, _
  width:=200, _
  Height:=50) _
  .Name = "Text" 'シェイプの名前

With pp.Slides(pp.Slides.Count).Shapes("Text").TextFrame.TextRange
  .Text = "サンプル" '表示テキスト
  .Font.Name = "Meiryo UI" 'フォント名
  .Font.Size = 20 'フォントサイズ
End With

      テキストボックス挿入時に、シェイプの名前としての固有の文字列を設定しておいて（2～8行）、そのシェイプに対してテキストやフォントなどの設定を行う（10～14行）という。11～13行はドットから始まってるので宙ぶらりんじゃないのか、という感じがするかもしれませんが、Withで省略されているので大丈夫なのです。Withについてはこちらの記事がめちゃめちゃわかりやすいです。

      今回はExcelVBAからPowerPointを操作するというちょっと特殊な例なので難しいと思いますが、問題解決の鍵はひとえに検索スキルだと思っています。経験によるモノもあるのですが、欲しい情報が出てくるまで単語を変えてアタックし続けるといいますか…、こちらで書いたことがあるので、よろしければ参考になさってください（もうご覧でしたらすみません）。

  5. adachi より:
    2017年12月9日 8:44 PM

    *youさま

    お忙しいところ、早速回答いただきありがとうございます。

    恥ずかしながら私は基礎的な理解を後回しにして、ネットで出てきたコードをかたっぱしから試しておりました。。

    OFFICE TANAKAさんのWith やピリオドについての説明わかりやすかったです。

    また、*youさまの書かれた、ダブルクォーテーションを使って検索というのも、ためになります。

    *youさまのVBA入門の記事読ませていただきます。
    いろいろと丁寧に教えてくださり感謝です。

    また、手詰まりになった時にご連絡させてください。
    すみませんです。
    なにとぞよろしくお願いいたします。

    返信

コメントを残す

メールアドレスが公開されることはありません。 ※ が付いている欄は必須項目です

このサイトはスパムを低減するために Akismet を使っています。コメントデータの処理方法の詳細はこちらをご覧ください。

コメントは承認制ですので、反映までしばらくお待ち下さい。（稀にスパムの誤判定にて届かないこともあるようですので、必要な際はお問い合わせからお願い致します。）

YouTubeでQ&Aコンテンツを企画しています

運営しているYouTubeチャンネルで、ご相談やご質問を募集しています。動画のコメントやお問い合わせページからお気軽にご相談をお寄せください。