PowerPointの表をExcelへ書き出すマクロ パワポの表・TABLEを取り込む PowerPoint Table Row Column Cell VBA

0.やりたいこと
パワーポイントの指定した表(TABLE)
を
エクセルの指定したシート・位置に書き出したい

Excelのマクロを使用してパワポの表を取り込む
そんな処理にチャレンジしてみます。

youtu.be
https://youtu.be/wjxG6L4il3w
目次
00:00 0.やりたいこと
00:29 1.アクティブなPowerPoint表の一覧を取得
11:25 2.アクティブなPowerPoint表を一括でExcelのシートへ
16:00 行と列のループでデータをセット
17:00 3.指定した表を指定した位置へ取り込む
19:45 ソースの説明 デバッグほか
23:34 転記処理のデバッグ
27:23 4.指定したファイルを開き、表を取り込む
31:07 会議で使用した報告書パワポからデータを抜く？
34:45 コードのポイントを説明
37:47 終わりの挨拶 と TABLEを直接Copyも一つの方法？

1.アクティブなPowerPoint表の一覧をテストで取得 00:29 ～

スライドのループ
シェイプのループ
テーブルの判断
名前と行数、列数の表示

Excelシートイメージ

B列 C列 D列 E列 F列
ページ数 表の名前 行数 列数 1行目内容(カンマ区切り)
1 表1 7 5 順位,,,,
2 セリーグ

スライドのループ For ppPAGE = 1 To ppApp.ActivePresentation.Slides.Count
シェイプのループ For Each ppShape In ppApp.ActivePresentation.Slides(ppPAGE).Shapes
テーブルの判断 If ppShape.HasTable = msoTrue Then '表 TABLE あり
名前と行数、列数の表示
ppTABLE.Rows.Count '行数
ppTABLE.Columns.Count '列数

1行目のデータは、

strWORK = ""  'ワークを初期化
For n = 1 To ppTABLE.Columns.Count '列数分ループ
    'TabelからCell(1, n)でShapeを取得
    '.TextFrame.TextRange.Text で やっとテキストまでたどり着く
    strWORK = strWORK & ppTABLE.Cell(1, n).Shape.TextFrame.TextRange.Text & ","
Next

で取り出してみました。

※セル内改行をチェックする

2.アクティブなPowerPoint表を一括でExcelのシートへ 11:25 ～

シートイメージ

アクティブシートのA10 10行目以降に表・TABLEを書き込む

A10列から書き込む
パワポプレゼンの名前※ファイル名

スライド番号:1　表の名前　y行 x列

表の中身、テキストをセルに書き込む

大きな流れ、
スライドのループ
シェイプのループ
テーブルの判断
Excelシートにパワポテーブルを書き出す

ppTABLE.Cell(行, 列).Shape.TextFrame.TextRange.Text

↑をループで回しただけかな・・・

3.指定した表を指定した位置へ取り込む 17:00 ～

無条件に全ての表を順番に取り出してましたが、
パワポの指定した表 (これもアクティブな開かれた既存パワポの表だけど)
を
エクセルの指定した位置へセット
そんな処理をテストしてみます。

Excelシートイメージ

B列 C列 D列 E列
PowerPoint Excel
ページ数 表の名前 シート名 書き込む場所(左上のセル番地)
1 表1
2 セリーグ

'やっと転記処理↑で入力:PowerPointと出力:Excelが決まったので、転記する
'pp:Tableのデータを取得してセットする
For n行 = 1 To ppTABLE.Rows.Count '行数分ループ
    For n列 = 1 To ppTABLE.Columns.Count '列数分ループ
        'TabelからCell(n行, n列)でShapeを取得
        '.TextFrame.TextRange.Text で やっとテキストまでたどり着く
        strWORK = ppTABLE.Cell(n行, n列).Shape.TextFrame.TextRange.Text
        exTABLE.Offset(n行 - 1, n列 - 1) = strWORK '↑のデータをセットする
        '↑左上の番地からOffsetなので、-1して細工、美しくないなぁ・・・
    Next
Next

↑exTABLE.Offset(n行 - 1, n列 - 1)が気になるけど、
こんな感じで指定位置にセットできました。

4.指定したファイルを開き、表を取り込む 27:23 ～

現在までのテストで、
開いたパワポの表
から
マクロのブック(アクティブブック)
に表を取り込んでましたが、
下記のように、指定したパワポから指定したブックへデータをセットする、
定型作業だと、そんな処理の流れになると思います。
※実際の業務だとシナリオ通りにデータが流れなかったりするんだけど・・・
(ページや表の名前、セット位置が変わったりして・・実戦ではうまくいかなかったり・・・)

Excelシートイメージ

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

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

と
指定されたファイルを開き、
指定した表を指定した位置へ取り込むそんなテストを行ってみます。

B列 C列 D列 E列
PowerPoint Excel
ページ数 表の名前 シート名 書き込む場所(左上のセル番地)
1 表1
2 セリーグ

PowerPointとExcelファイルを開く処理を追加しただけです。

ポイントは、Open処理でオブジェクトを返してくれるので、
これを使用すると楽って感じかなぁ

    'いつも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  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意

'とか、オープンで開いたオブジェクトを取得できます。
'Excel出力側も

    '出力先: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

でチェックしました。

パワポからデータ取得処理の参考となれば幸いです。

---

ソースコード全体

Option Explicit

'起動済みの既存 パワーポイント スライド .Shapes から
'表 TABEL の情報を取得する
'スライド番号(Page),表の名前,行数,列数,1行目のサンプルデータを取得
Sub test001_PowerPoint表の情報を取得()

    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

    Range("4:999").ClearContents  '5行目から999までを固定クリアの手抜き
    '見出しを書き込む
    Range("B4") = "Page番号"
    Range("C4") = "表の名前"
    Range("D4") = "行数"
    Range("E4") = "列数"
    Range("F4") = "表1行目のデータ(項目名の場合が多いかな？)"

    Dim ppPAGE As Integer   'pp:スライドページ数
    Dim exROW  As Integer   'excle:セットする行
    Dim ppShape As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
    Dim ppTABLE As PowerPoint.Table 'パワポのテーブル
    Dim n As Integer
    Dim strWORK As String
        
    exROW = 5  '取得したテキストデータを5行目から書きたいので
    For ppPAGE = 1 To ppApp.ActivePresentation.Slides.Count  'スライド数ループ pページ
        'pp:Pageのスライド内のシェイプを探る
        For Each ppShape In ppApp.ActivePresentation.Slides(ppPAGE).Shapes
            'オブジェクトが表を持っているか？チェックしてからセット
            If ppShape.HasTable = msoTrue Then '表 TABLE あり
            
                Cells(exROW, "B") = ppPAGE   'スライド番号(ページ番号)
                Cells(exROW, "C") = ppShape.Name  'オブジェクトの名前が表の名前
                
                'テーブルの情報を取得
                Set ppTABLE = ppShape.Table  'シェイプの表を変数に代入
                Cells(exROW, "D") = ppTABLE.Rows.Count    '行数
                Cells(exROW, "E") = ppTABLE.Columns.Count '列数
                
                '1行目のデータを取得してセットする
                strWORK = ""  'ワークを初期化
                For n = 1 To ppTABLE.Columns.Count '列数分ループ
                    'TabelからCell(1, n)でShapeを取得
                    '.TextFrame.TextRange.Text で やっとテキストまでたどり着く
                    strWORK = strWORK & ppTABLE.Cell(1, n).Shape.TextFrame.TextRange.Text & ","
                Next
                Cells(exROW, "F") = strWORK  '↑上で作られた1行目のデータをセットする
                
                '忘れずにExcel行カウンタを次の行へ
                exROW = exROW + 1   'excel:セットする行を次へ
            End If
        Next
    Next
    
    MsgBox "処理終了、確認してね"

End Sub

'起動済みの既存 パワーポイント スライド .Shapes から
'表 TABEL の情報を取得する
'スライド番号(Page),表の名前,行数,列数を取得
'TABLEデータを書き出す
Sub test002_PowerPointの表を全て書き出すテスト()

    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

    Range("10:999").ClearContents  '10行目から999までを固定クリアの手抜き
    
    'パワポ 名前とPathの書き込みをおまけで(こんなプロパティあるよ紹介)
    Range("A10") = "ActivePresentation.Name=" & ppApp.ActivePresentation.Name
    Range("A11") = "ActivePresentation.Path=" & ppApp.ActivePresentation.Path

    Dim ppPAGE As Integer   'pp:スライドページ数
    Dim exROW  As Integer   'excle:セットする行
    Dim ppShape As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
    Dim ppTABLE As PowerPoint.Table 'パワポのテーブル
    Dim n行 As Integer, n列 As Integer
    Dim strWORK As String

    exROW = 13  '取得した表データを13行目から書きたいので
    For ppPAGE = 1 To ppApp.ActivePresentation.Slides.Count  'スライド数ループ pページ
        'pp:Pageのスライド内のシェイプを探る
        For Each ppShape In ppApp.ActivePresentation.Slides(ppPAGE).Shapes
            'オブジェクトが表を持っているか？チェックしてからセット
            If ppShape.HasTable = msoTrue Then '表 TABLE あり
            
                Cells(exROW, "A") = "スライド: " & ppPAGE & "ページ目"   'スライド番号(ページ番号)
                exROW = exROW + 1 'セット位置を次へ
                Cells(exROW, "A") = "表の名前は:" & ppShape.Name  '表の名前
                exROW = exROW + 1 'セット位置を次へ
                
                'テーブルの情報を取得
                Set ppTABLE = ppShape.Table  'シェイプの表を変数に代入
                Cells(exROW, "A") = "行数:" & ppTABLE.Rows.Count    '行数
                Cells(exROW, "B") = "列数" & ppTABLE.Columns.Count '列数
                exROW = exROW + 1 'セット位置を次へ
                
                'Tableのデータを取得してセットする
                For n行 = 1 To ppTABLE.Rows.Count '行数分ループ
                    
                    For n列 = 1 To ppTABLE.Columns.Count '列数分ループ
                        'TabelからCell(n行, n列)でShapeを取得
                        '.TextFrame.TextRange.Text で やっとテキストまでたどり着く
                        strWORK = ppTABLE.Cell(n行, n列).Shape.TextFrame.TextRange.Text
                        Cells(exROW, n列) = strWORK  '↑のデータをセットする
                    Next
                
                    '忘れずにExcel行カウンタを次の行へ
                    exROW = exROW + 1   'excel:セットする行を次へ
                Next
                
                exROW = exROW + 1   'excel:セットする行を次へ
            End If
        Next
    Next
    
    MsgBox "処理終了、確認してね"

End Sub

'入力:起動済みの既存 パワポ 指定ページ、指定した表のTABEL
'出力:アクティブブックの指定したシートに書き出す
Sub test003_PowerPoint指定した表を指定シート位置に書き出す()

    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 exROW  As Integer   'excle:指示パラメーターの行
    Dim ppShape As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
    Dim ppTABLE As PowerPoint.Table 'パワポのテーブル
    Dim n行 As Integer, n列 As Integer
    Dim strWORK As String
    
    Dim exSHNAME As String   'Excle:シート名
    Dim exAddress As String  'Excel:セットする左上の番地
    Dim exTABLE As Excel.Range  '変数名TABLEなのに、左上の位置を代入する変数

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

        'pp側のテーブルをセット、pageと名前を指定してSetする
        ppPAGE = Val(Cells(exROW, "B"))
        ppTNAME = Trim(Cells(exROW, "C"))  '前後の空白をとる、余計なことしやがって
        
        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(exROW, "A") = strWORK  'A列にエラーを吐く、F列を結果列の方がいいかも？
            MsgBox strWORK, vbExclamation
            Exit Sub
        End If

        'Excel側のテーブルセット位置、左上をセットする
        exSHNAME = Trim(Cells(exROW, "D"))    'Excle:シート名
        exAddress = Trim(Cells(exROW, "E"))   'Excel:セットする左上の番地

        Set exTABLE = Nothing  'エラーチェックも兼ねて、初期化
        On Error Resume Next   '↓でRange型にシートと番地でセットしてチェック
        Set exTABLE = Sheets(exSHNAME).Range(exAddress)
        On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
        If exTABLE Is Nothing Then
            strWORK = "エラー Excel シート名とセット位置 番地を確認してください"
            Cells(exROW, "A") = strWORK  'A列にエラーを吐く、F列を結果列の方がいいかも？
            MsgBox strWORK, vbExclamation
            Exit Sub
        End If
        
        'やっと転記処理↑で入力:PowerPointと出力:Excelが決まったので、転記する
        'pp:Tableのデータを取得してセットする
        For n行 = 1 To ppTABLE.Rows.Count '行数分ループ
            For n列 = 1 To ppTABLE.Columns.Count '列数分ループ
                'TabelからCell(n行, n列)でShapeを取得
                '.TextFrame.TextRange.Text で やっとテキストまでたどり着く
                strWORK = ppTABLE.Cell(n行, n列).Shape.TextFrame.TextRange.Text
                exTABLE.Offset(n行 - 1, n列 - 1) = strWORK '↑のデータをセットする
                '↑左上の番地からOffsetなので、-1して細工、美しくないなぁ・・・
            Next
        Next

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

End Sub


'入力:パワポ pptxを開き、指定ページ、指定した表のTABEL
'出力:出力先ブック xlsxを開き、指定したシートに書き出す
Sub test004_PowerPointとExcelを開き表を指定シート位置に書き出す()

    '入力元:パワポのファイルを開く
    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 exROW  As Integer   'excle:指示パラメーターの行
    Dim ppShape As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
    Dim ppTABLE As PowerPoint.Table 'パワポのテーブル
    
    Dim n行 As Integer, n列 As Integer
    Dim strWORK As String
    
    Dim exSHNAME As String   'Excle:シート名
    Dim exAddress As String  'Excel:セットする左上の番地
    Dim exTABLE As Excel.Range  '変数名TABLEなのに、左上の位置を代入する変数

    'TEST003より変更点
    ThisWorkbook.Activate  '↑で開いたブックがアクティブになるので
    '↑忘れずにマクロ実行しているこのブックをアクティブにする
    '↓だったら、下記のアクティブシートに対して行うコードも変えろよ・・

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

        'pp側のテーブルをセット、pageと名前を指定してSetする
        ppPAGE = Val(Cells(exROW, "B"))
        ppTNAME = Trim(Cells(exROW, "C"))  '前後の空白をとる、余計なことしやがって
        
        Set ppTABLE = Nothing  'エラーチェックも兼ねて、初期化
        On Error Resume Next   '↓でSet 取得エラー時に次へ ページか表名が間違えている時
        '※TEST003から変更、いつものActivePresentationから開いたファイルにする
        Set ppTABLE = ppプレゼン.Slides(ppPAGE).Shapes(ppTNAME).Table

        On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
        If ppTABLE Is Nothing Then
            strWORK = "エラー パワポの表が見つかりません、ページと表名を確認"
            Cells(exROW, "A") = strWORK  'A列にエラーを吐く、F列を結果列の方がいいかも？
            MsgBox strWORK, vbExclamation
            Exit Sub
        End If

        'Excel側のテーブルセット位置、左上をセットする
        exSHNAME = Trim(Cells(exROW, "D"))    'Excle:シート名
        exAddress = Trim(Cells(exROW, "E"))   'Excel:セットする左上の番地

        Set exTABLE = Nothing  'エラーチェックも兼ねて、初期化
        On Error Resume Next   '↓でRange型にシートと番地でセットしてチェック
        '※開いたブック exWKBOOKのシートに出力するため test003から変更箇所
        Set exTABLE = exWKBOOK.Sheets(exSHNAME).Range(exAddress)
        On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
        If exTABLE Is Nothing Then
            strWORK = "エラー Excel シート名とセット位置 番地を確認してください"
            Cells(exROW, "A") = strWORK  'A列にエラーを吐く、F列を結果列の方がいいかも？
            MsgBox strWORK, vbExclamation
            Exit Sub
        End If
        
        'やっと転記処理↑で入力:PowerPointと出力:Excelが決まったので、転記する
        'pp:Tableのデータを取得してセットする
        For n行 = 1 To ppTABLE.Rows.Count '行数分ループ
            For n列 = 1 To ppTABLE.Columns.Count '列数分ループ
                'TabelからCell(n行, n列)でShapeを取得
                '.TextFrame.TextRange.Text で やっとテキストまでたどり着く
                strWORK = ppTABLE.Cell(n行, n列).Shape.TextFrame.TextRange.Text
                exTABLE.Offset(n行 - 1, n列 - 1) = strWORK '↑のデータをセットする
                '↑左上の番地からOffsetなので、-1して細工、美しくないなぁ・・・
            Next
        Next

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

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

End Sub

---

関連記事:
ken3memo.hatenablog.com