Excel複数画像ファイルリスト から パワポのスライドに図・画像を貼り付ける パワポ図を作成

Excelシートのイメージ

B2にフォルダー
B6～ファイル名、C,D,E,F列にセット位置
に記載されたExcelの画像ファイル名リスト・表 から
パワポのスライドを複数ページ作成する

QAサイト
teratail.com
の質問に答えてみた。

いつもの あのあの そのその イライラ動画解説
www.youtube.com
https://www.youtube.com/watch?v=ELYLw9dn5Y4
↑こんな感じでテストしてみました。
目次
00:00 あいさつ、やりたいこと
00:34 実行結果を先に見せる
02:35 コードの説明
05:23 ポイントはShapes.AddPictureで画像の追加
07:18 テスト実行

ポイント
.Shapes.AddPicture で パワポのスライドに画像ファイル指定で図を挿入できるので、
google:Shapes AddPicture PowerPoint をぐぐってみてください。

#ExcelVBA #PowerPointVBA #マクロ #画像ファイル #パワポ #貼り付け #デバッグ #Shapes #AddPicture

コードをアレンジして使ってみてください。
ソースコード

'Excelの画像ファイルリストから、
'パワポのスライドを作成してみます。
Sub ExcelからPowerPointへ画像ファイルをセット20220823()

    Dim ppApp As Object   'PowerPoint.Application
    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True
    '新規プレゼンファイルの追加 https://www.youtube.com/watch?v=5ZQMhv0s9qs
    ppApp.Presentations.Add '新規プレゼンの追加
    
    Dim objSlide As Object   'スライドオブジェクト
    Dim objPicture As Object '図 Picture

    Dim r As Range    'ファイルの表、基準の位置 表の左上 B5
    Dim p As Integer  'パワポ側Page と Excel表の行カウンタ
    Dim strFNAME As String  '画像ファイル名
    
    Set r = Range("B5")  'セット開始位置 B6からセット
    p = 1   'スライドのPページ目、兼、画像のP枚目として使用

    While Trim(r.Offset(p, 0) & "") <> "" 'ファイル名が空になるまでループ
        'パワポのスライドを追加する https://www.youtube.com/watch?v=0oHFihJNTLo
        'p枚目のスライド追加 レイアウトは12 ppLayoutBlank
        Set objSlide = ppApp.ActivePresentation.Slides.Add(p, 12)
        'ActiveWindow.Selection.SlideRange.Layout = 12  '12:ppLayoutBlank
             
        '画像ファイル名はB2のフォルダ+ファイル名です b2は\xxxxx\と\で終わってね
        strFNAME = Trim(Range("B2")) & r.Offset(p, 0) 'ファイル名
     
        '画像ファイルを挿入 画像ファイル名を指定してとりあえず0,0に挿入
        Set objPicture = objSlide.Shapes.AddPicture(strFNAME, False, True, 0, 0)
    
        '図 画像 の プロパティをセット ↑上で挿入された画像のプロパティを調整
        With objPicture
            .Top = r.Offset(p, 1)    '位置 上
            .Left = r.Offset(p, 2)   '位置 左
            .Width = r.Offset(p, 3)  '幅
            .Height = r.Offset(p, 4) '高さ
        End With
    
        '次のデータ、次のスライドページへ
        p = p + 1
    Wend
    
    MsgBox "処理終了 パワポを確認してください"
    'ここまで

End Sub

Sub B2のフォルダからファイル名を取得()

    
    Rows("6:999").Delete Shift:=xlUp  '決め打ちはよくないけど、データ行削除
    
    Dim r As Range
    Set r = Range("B6")  'セット開始位置 B6からセット
    
    Dim n As Integer
    n = 0
    
    Dim strFNAME As String  'ファイル名
    
    strFNAME = Dir(Trim(Range("B2").Text) & "*.*")  'B2のフォルダからファイル名取得
    While strFNAME <> ""  'ファイル名が無くなるまでループ
        r.Offset(n, 0) = strFNAME
        n = n + 1
        strFNAME = Dir()
    Wend

End Sub

コードをアレンジして、使ってみてください。

---

過去記事
下記、VBSで似た処理をやってみたパターン
ken3memo.hatenablog.com