Excel表(セル範囲) を パワポの表TABLEへ転記する PowerPoint Table Row Column Cell VBA

0.やりたいこと
Excelシート+セル範囲のテキストデータ
を
パワポのPage指定した表TABLEへ転記する。
※データを流し込む、差し込む、イメージです

youtu.be
https://youtu.be/x68nZfCgFGc
目次
00:00 0.やりたいこと
00:58 1.シートのセル範囲をパワポの指定Pageの表へ転記する
04:18 1.1 簡単なコード説明
10:22 行と列のループを説明
13:18 1.2 表のサイズが合っていないときのエラーを説明
17:52 1.3 テストでピボットの結果を転記、流し込む
24:02 2.指定したファイルを開き、Excelの範囲をパワポに転記する
30:18 ソースコードの説明
33:38 終わりの挨拶 問題点や今後の課題？

1.シートのセル範囲をパワポの指定Pageの表へ転記する 00:58 ～

シートイメージ

Excel －－－－－－ → PowerPoint
B列 C列 D列 E列
シート名 セル範囲 Page番号 表の名前
順位表 a3:e9 3 セリーグ
順位表 $A$11:$E$17 3 パリーグ

↑シート名とセル範囲を指定する
エクセル 順位表!a3:e9
を
パワポの スライド3ページ の 表名:セリーグ にセットする
次の指示 順位表!$A$11:$E$17 → 3Pageの表名:パリーグにセットする

シートに
B,C列 セット元(Excel:シート名と範囲)
D,E列 セット先(PowerPoint:スライドのページと表の名前)※アクティブな開かれているパワポ
を記載して、自動転記する。
そんな処理を行いたいと思います。

※a3:e9 や $A$11:$E$17など範囲の書き方を説明する。

1.1 簡単なコード説明(PowerPoint側のテーブルは前回の動画を見てもらう？) 04:18 ～

'pp側のテーブルをセット、pageと名前を指定してSetする
ppPAGE = Val(Cells(nROW, "D"))
ppTNAME = Trim(Cells(nROW, "E"))  '前後の空白をとる、余計なことしやがって
        
Set ppTABLE = ppApp.ActivePresentation.Slides(ppPAGE).Shapes(ppTNAME).Table

'Excel側のテーブルセット位置、範囲をセットする
strSNAME = Trim(Cells(nROW, "B"))    'Excle:シート名
strAddress = Trim(Cells(nROW, "C"))   'Excel:セルの範囲

Set exTABLE = Sheets(strSNAME).Range(strAddress)

'やっと転記処理↑で入力:Excelと出力:PowerPointが決まったので、転記する 
For n行 = 1 To exTABLE.Rows.Count '行数分ループ
For n列 = 1 To exTABLE.Columns.Count '列数分ループ

↑行・列のループを作り
'Cell(n行, n列)でテキストを取得
strWORK = exTABLE.Cells(n行, n列).Text  'excelのテキストを
ppTABLE.Cell(n行, n列).Shape.TextFrame.TextRange.Text = strWORK 'パワポにセット

↑の繰り返しを作っただけです 10:22 ～ 解説してます
(表の形をチェックしていないので、いろいろな不具合を含んだコードです)

1.2 ※※表のサイズが合っていないときのエラーを説明 13:18 ～ 動画解説

Excelの指定範囲が大きかった時、表を流し込むとき、行や列があふれたとき

1.3 テストでピボットの結果を転記、流し込む 17:52 ～ 説明

ア.集計データ(DATAシートのピボット結果)を書き出したいけど、現在の方法だと、
　　見出しも含めた範囲なので、項目名が上書きされる

イ.範囲の人数(行数)増やしたとき、　新入社員が入りました、おめでとう。
　　セット側パワポも手作業で増やさないと？
　　表の形を合わせるのを自動と言わなかったり

ウ.逆に、部署移動、担当者が減ったとき、パワポの表/行を自動で少なくしたいよね？

2.指定したファイルを開き、Excelの範囲をパワポに転記する 24:02 ～

現在までのテストで、
開いたパワポの表(アクティブなパワポ)
に
Excelの範囲(アクティブブック)
を転記、流し込んでましたが、

下記のように、
指定したExcelブック と パワポのスライドを開き、
シートのデータを流し込む、

定型作業だと、そんな処理の流れになると思います。
※実際の業務だとシナリオ通りにデータが流れなかったりするんだけど・・・
(ページや表の名前、セット位置が変わったりして・・実戦ではうまくいかなかったり・・・)

仕様を少し変更してみます。

設定シートのイメージ

B3:PPファイル
B4:Excelファイル

と
指定されたファイルを開き、
指定したシート!範囲を指定したスライドの表へ流し込むテストを行ってみます。

PowerPoint D:\2022\202210会議資料.pptx
ExcleBook D:\2022\202210売上順位.xlsx

Excel －－－－－－ → PowerPoint
B列 C列 D列 E列
シート名 セル範囲 Page番号 表の名前
東京 F3:G8 2 表 4
名古屋 F3:G8 3 表 4
大阪 F3:G8 4 表 4

ポイントは、特になく ぉぃぉぃ 30:18 ～ コードの説明
ただ、ファイルを開いただけでした・・・※アクティブに注意・・・

    'いつもActivePresentationでやってるけど変数を使用
    Dim ppプレゼン As PowerPoint.Presentation  'pp:プレゼンテーション
    Set ppプレゼン = ppApp.Presentations.Open(Range("B3")) 'B3のファイル名を開く
    '↑単純に、.Open "ファイル名" で開いただけです

    '入力元:Excelのブックを開く Workbooks.Open Filename:="D:\2022\順位.xlsx"
    Dim exWKBOOK As Excel.Workbook
    Set exWKBOOK = Workbooks.Open(Range("B4")) 'B4のファイル名を開く
     '↑単純に、.Open "ファイル名" で開いただけです

あとは、その変数を使い

    Set ppTABLE = ppプレゼン.Slides(ppPAGE).Shapes(ppTNAME).Table
    'Openしたプレゼンファイル↑のテーブルを見る TEST001より変更点
 
    'Excel側のテーブルセット位置、範囲をセットする
    strSNAME = Trim(Cells(nROW, "B"))    'Excle:シート名
    strAddress = Trim(Cells(nROW, "C"))   'Excel:セルの範囲
    '↓でRange型にシートと範囲でセットしてチェック
    Set exTABLE = exWKBOOK.Sheets(strSNAME).Range(strAddress)
    '入力元の↑OpenしたブックがexWKBOOKなので、ここの範囲に変更 TEST001から変更箇所

として、開いたファイルを使用しただけです。

前回の動画:逆の処理 PowerPointの表を → Excelの指定位置にセットする方法
https://youtu.be/wjxG6L4il3w
で↑ファイルの開き方について、少し解説してます、
よかったら時間のある時に見てください。

終わりの挨拶:
問題点や今後の課題？ 33:38 ～

以上、簡単な説明ですが、
今回の動画と合わせてみて、
自動転記処理のヒントとなれば幸いです。

アレンジして使ってみてください。

---

ソースコード全体:

Option Explicit


'入力:アクティブブックの指定したシートと範囲 DATA!A1:D5 などの範囲
'出力:起動済みのアクティブなパワポ 指定ページ、指定した表のTABEL
Sub test001_シートのセル範囲をパワポの指定Pageの表へ転記()

    '開いているセット先、アクティブなパワポを捕まえる
    Dim ppApp As PowerPoint.Application 'ツール・参照設定してください

    On Error Resume Next  '取得エラー時に次へ
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意

    If ppApp Is Nothing Then
        MsgBox "パワポを取得できません。スライドを開いてから、再テストしてね"
        Exit Sub
    End If

    Dim ppPAGE As Integer   'pp:スライドページ数
    Dim ppTNAME As String   'pp:表・テーブル名
    
    Dim nROW  As Integer    'Excle:指示パラメーターの行
    Dim ppShape As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
    Dim ppTABLE As PowerPoint.Table 'パワポのテーブル
    Dim n行 As Integer, n列 As Integer
    Dim strWORK As String
    
    '入力元のセル範囲を Rangeオブジェクトに代入する
    Dim strSNAME As String   'Excle:シート名
    Dim strAddress As String 'Excel:セットする範囲
    Dim exTABLE As Excel.Range  '変数名TABLEだけど、単なるセット範囲です

    'ExcelのB10～にある指示データがなくなるまでループしたいので
    For nROW = 10 To 999  'また、固定のループで↓の空白で抜けるループかよ
        Cells(nROW, "F") = ""   'F列を臨時のエラー表示に使っているのでクリアする
        If Len(Trim(Cells(nROW, "C"))) = 0 Then Exit For 'C列の範囲が空白の時ループを抜ける

        'pp側のテーブルをセット、pageと名前を指定してSetする
        ppPAGE = Val(Cells(nROW, "D"))
        ppTNAME = Trim(Cells(nROW, "E"))  '前後の空白をとる、余計なことしやがって
        
        Set ppTABLE = Nothing  'エラーチェックも兼ねて、初期化
        On Error Resume Next   '↓でSet 取得エラー時に次へ ページか表名が間違えている時
        Set ppTABLE = ppApp.ActivePresentation.Slides(ppPAGE).Shapes(ppTNAME).Table
        On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
        If ppTABLE Is Nothing Then
            strWORK = "エラー 出力先パワポの表が見つかりません、ページと表名を確認"
            Cells(nROW, "F") = strWORK  'F列にエラーを吐く
            MsgBox strWORK, vbExclamation
            Exit Sub
        End If

        'Excel側のテーブルセット位置、範囲をセットする
        strSNAME = Trim(Cells(nROW, "B"))    'Excle:シート名
        strAddress = Trim(Cells(nROW, "C"))   'Excel:セルの範囲

        Set exTABLE = Nothing  'エラーチェックも兼ねて、初期化
        On Error Resume Next   '↓でRange型にシートと範囲でセットしてチェック
        Set exTABLE = Sheets(strSNAME).Range(strAddress)
        On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
        If exTABLE Is Nothing Then
            strWORK = "エラー Excel シート名と範囲を確認してください"
            Cells(nROW, "F") = strWORK  'F列にエラーを吐く
            MsgBox strWORK, vbExclamation
            Exit Sub
        End If
        
        'やっと転記処理↑で入力:Excelと出力:PowerPointが決まったので、転記する
        'pp:Tableのデータを取得してセットする
        For n行 = 1 To exTABLE.Rows.Count '行数分ループ
            For n列 = 1 To exTABLE.Columns.Count '列数分ループ
                'Cell(n行, n列)でテキストを取得
                strWORK = exTABLE.Cells(n行, n列).Text
                'ここで、行・列の形が合わないときのエラー対策
                On Error Resume Next  '↓の代入でエラーの場合があるので
                ppTABLE.Cell(n行, n列).Shape.TextFrame.TextRange.Text = strWORK
                If Err.Number <> 0 Then '0以外、エラー発生なら
                    Cells(nROW, "F") = exTABLE.Cells(n行, n列).Address & " エラー 表のサイズを確認してください"
                    Exit For  'Exit Subと迷ったが、継続して次の表を処理するためForにした
                End If
                On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
            Next
            'コードとして、どうかと思うが、二重ループを抜けたかったので
            If Err.Number <> 0 Then '↑0以外、エラー発生なら
                Err.Clear  'エラーをクリア、次の表、範囲へ行くため
                Exit For
            End If
        Next

    Next nROW
    
    MsgBox "処理終了、確認してね"

End Sub

Sub test002_ExcelとPowerPointを開き表を流し込む()

    '出力先:パワポのファイルを開く
    Dim ppApp As PowerPoint.Application 'ツール・参照設定してください

    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True '可視にする

    'いつもActivePresentationでやってるけど変数を使用
    Dim ppプレゼン As PowerPoint.Presentation  'pp:プレゼンテーション
    Set ppプレゼン = Nothing '初期化、エラーチェックもかねて
    On Error Resume Next   '↓でSet 取得エラー時に次へ ファイルが開けなかった時
    Set ppプレゼン = ppApp.Presentations.Open(Range("B3")) 'B3のファイル名を開く
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
    '↑単純に、.Open "ファイル名" で開いただけです
    If ppプレゼン Is Nothing Then
        MsgBox "パワポのファイル名、パスを確認してください", vbExclamation
        Exit Sub
    End If

    '入力元:Excelのブックを開く Workbooks.Open Filename:="D:\2022\順位.xlsx"
    Dim exWKBOOK As Excel.Workbook
    Set exWKBOOK = Nothing '初期化、エラーチェックもかねて
    On Error Resume Next   '↓でSet 取得エラー時に次へ ファイルが開けなかった時
    Set exWKBOOK = Workbooks.Open(Range("B4")) 'B4のファイル名を開く
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
    '↑単純に、.Open "ファイル名" で開いただけです
    If exWKBOOK Is Nothing Then
        MsgBox "Excelブックのファイル名、パスを確認してください", vbExclamation
        Exit Sub
    End If

    Dim ppPAGE As Integer   'pp:スライドページ数
    Dim ppTNAME As String   'pp:表・テーブル名
    
    Dim nROW  As Integer    'Excle:指示パラメーターの行
    Dim ppShape As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
    Dim ppTABLE As PowerPoint.Table 'パワポのテーブル
    Dim n行 As Integer, n列 As Integer
    Dim strWORK As String
    
    '入力元のセル範囲を Rangeオブジェクトに代入する
    Dim strSNAME As String   'Excle:シート名
    Dim strAddress As String 'Excel:セットする範囲
    Dim exTABLE As Excel.Range  '変数名TABLEだけど、単なるセット範囲です

    '↑のOPENでアクティブブックが向こうに行ったので、
    'アクティブをマクロブック(このブックに取り戻す)
    ThisWorkbook.Activate  'まぁ、美しくないけどね ※TEST001から変更場所

    'ExcelのB10～にある指示データがなくなるまでループしたいので
    For nROW = 10 To 999  'また、固定のループで↓の空白で抜けるループかよ
        Cells(nROW, "F") = ""   'F列を臨時のエラー表示に使っているのでクリアする
        If Len(Trim(Cells(nROW, "C"))) = 0 Then Exit For 'C列の範囲が空白の時ループを抜ける

        'pp側のテーブルをセット、pageと名前を指定してSetする
        ppPAGE = Val(Cells(nROW, "D"))
        ppTNAME = Trim(Cells(nROW, "E"))  '前後の空白をとる、余計なことしやがって
        
        Set ppTABLE = Nothing  'エラーチェックも兼ねて、初期化
        On Error Resume Next   '↓でSet 取得エラー時に次へ ページか表名が間違えている時
        Set ppTABLE = ppプレゼン.Slides(ppPAGE).Shapes(ppTNAME).Table
        'Openしたプレゼンファイル↑のテーブルを見る TEST001より変更点
        On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
        
        If ppTABLE Is Nothing Then
            strWORK = "エラー 出力先パワポの表が見つかりません、ページと表名を確認"
            Cells(nROW, "F") = strWORK  'F列にエラーを吐く
            MsgBox strWORK, vbExclamation
            Exit Sub
        End If

        'Excel側のテーブルセット位置、範囲をセットする
        strSNAME = Trim(Cells(nROW, "B"))    'Excle:シート名
        strAddress = Trim(Cells(nROW, "C"))   'Excel:セルの範囲

        Set exTABLE = Nothing  'エラーチェックも兼ねて、初期化
        On Error Resume Next   '↓でRange型にシートと範囲でセットしてチェック
        Set exTABLE = exWKBOOK.Sheets(strSNAME).Range(strAddress)
        '入力元の↑OpenしたブックがexWKBOOKなので、ここの範囲に変更 TEST001から変更箇所
        On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
        
        If exTABLE Is Nothing Then
            strWORK = "エラー Excel シート名と範囲を確認してください"
            Cells(nROW, "F") = strWORK  'F列にエラーを吐く
            MsgBox strWORK, vbExclamation
            Exit Sub
        End If
        
        'やっと転記処理↑で入力:Excelと出力:PowerPointが決まったので、転記する
        'pp:Tableのデータを取得してセットする
        For n行 = 1 To exTABLE.Rows.Count '行数分ループ
            For n列 = 1 To exTABLE.Columns.Count '列数分ループ
                'Cell(n行, n列)でテキストを取得
                strWORK = exTABLE.Cells(n行, n列).Text
                'ここで、行・列の形が合わないときのエラー対策
                On Error Resume Next  '↓の代入でエラーの場合があるので
                ppTABLE.Cell(n行, n列).Shape.TextFrame.TextRange.Text = strWORK
                If Err.Number <> 0 Then '0以外、エラー発生なら
                    Cells(nROW, "F") = exTABLE.Cells(n行, n列).Address & " エラー 表のサイズを確認してください"
                    Exit For  'Exit Subと迷ったが、継続して次の表を処理するためForにした
                End If
                On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
            Next
            'コードとして、どうかと思うが、二重ループを抜けたかったので
            If Err.Number <> 0 Then '↑0以外、エラー発生なら
                Err.Clear  'エラーをクリア、次の表、範囲へ行くため
                Exit For
            End If
        Next

    Next nROW
    
    MsgBox "処理終了、確認してね"

    '↑ファイルが開きっぱなし
    '入力ファイルは閉じる
    '出力ファイルは上書き保存で閉じる？
    'そんな処理が必要かな、でも間違ったとき、確認しないと・・・

End Sub

---

PowerPoint 表 TABLE操作の関連ブログ(過去ブログ):
ken3memo.hatenablog.com
ken3memo.hatenablog.com