初投稿です。
このプログラムも正直もっといい方法があったような気もしますので、もっとこうしたらみたいな案があったらコメントでご指導ください。
この記事は以下の内容で提供しています。
作成目的
複数のパワーポイントにて挿入しているテーブルの内容をエクセルに出力すること
作成環境
- Excel(Microsoft Office Home and Business 2013)
- Windows10
注意事項
本VBAでは、以下の前提でパワーポイントの表を出力しています。
- テーブルにヘッダーがついている。（ex：出力項目 ）
- テーブルのカラム項目が固定している。
- ヘッダーがユニークである。
テーブルにヘッダーが入ってなかったり、カラム数が変動している場合は抽出できません。
別のものを探してください。
ソース
「パワーポイントのファイルを開く」と「表の全文字列をExcelに出力する」の二つのメソッドに分けていますが、これは「パワーポイントのファイルを開く」を他のプログラムでも使いまわすためです。
Call ～と 渡す引数さえ変更すれば他のプログラムでも流用できます。
Sub パワーポイントのファイルを開く()
Dim Path As String
Dim xl_wbk As Object
Set xl_wbk = Workbooks.Add '新規ワークブック追加
With Workbooks("パワーポイントの起動用マクロ.xlsm").Worksheets("Sheet1")
For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
Path = .Cells(i, 1).Value
'-------------------------------------------------
Call 表の全文字列をExcelに出力する(Path, xl_wbk) '対象のマクロを選択
'-------------------------------------------------
Next i
End With
End Sub
Public Function 表の全文字列をExcelに出力する(Path As String, xl_wbk As Object)
Dim ppapp As New PowerPoint.Application
Dim sld As PowerPoint.Slide
Dim shp As Object
Dim r As Long 'PowerPointの表の行番号
Dim c As Long 'PowerPointの表の列番号
Dim xl_app As Object
Dim xl_row As Long 'Excelの出力先行番号
ppapp.Visible = True
Set ppPR = ppapp.Presentations.Open(Path)
'出力先設定
xl_row = Cells(Rows.Count, 1).End(xlUp).Row + 1
'
For Each sld In ppPR.Slides
For Each shp In sld.Shapes
If shp.HasTable Then
With shp.Table
If .Columns.Count >= 2 Then
'ヘッダー「出力項目を判定」
If .Cell(1, 2).Shape.TextFrame.TextRange = "出力項目" Then
For r = 2 To .Rows.Count
For c = 1 To .Columns.Count
xl_wbk.Worksheets(1).Cells(xl_row, c ).Value = _
.Cell(r, c).Shape.TextFrame.TextRange
Next c
xl_row = xl_row + 1
Next r
End If
End If
End With
End If
Next shp
Next sld
ppapp.Quit
Set pptapp = Nothing
Set 表の全文字列をExcelに出力する = xl_wbk
End Function
解説
先述のプログラムは以下の4段階のロジックで動いています。
1.絶対参照で指定したURL先のパワーポイントを開く。
2.開いたパワーポイントのテーブルのヘッダーを判定する。
3.指定したヘッダーのテーブルをExcelに出力する。
4.開いたパワーポイントを閉じる。
これらのロジックを繰り返すことで、複数のパワーポイントを対象としています。
ロジック単位で、ソースの解説をしていきます。
1.絶対参照で指定したURL先のパワーポイントを開く。
こちらがパワーポイントを起動させるためのファイルです。
A列に、絶対参照形式でURLを入力しています。
（今回、途中までパワーポイント側に実装しようと思っていたため、拡張子がpptmになっておりますがpptxでももちろん大丈夫です。）
Sub パワーポイントのファイルを開く()
Dim Path As String
Dim xl_wbk As Object
Set xl_wbk = Workbooks.Add '新規ワークブック追加
With Workbooks("パワーポイントの起動用マクロ.xlsm").Worksheets("Sheet1")
For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
Path = .Cells(i, 1).Value
Call 表の全文字列をExcelに出力する(Path, xl_wbk) '対象のマクロを選択
Next i
End With
End Sub
では分解していきます。
Sub パワーポイントのファイルを開く()
Dim Path As String
Dim xl_wbk As Object
ここの部分は定義の箇所です。そんなに気にしなくても大丈夫です。
Pathとかxl_wbkとかの名称を変更しても以下の部分を変更すれば、特に影響は出ません。
As以降だけ気を付ければ大丈夫です。
Set xl_wbk = Workbooks.Add '新規ワークブック追加
ここの箇所では、Excelで新規のブックを作成しxl_wbkという名前を登録しています。
以降、xl_wbkは書き込みファイルをさします。もし書き込みたいファイルが決まっている場合、以下のように書き換えれば指定できます。（書き込みたいファイル：hogehoge.xlsx）
Set xl_wbk = Workbooks("hogehoge.xlsx")
A列に書かれた開きたいパワーポイントのURL（Path）と書き込みファイル（xl_wbk）を
ファンクション「表の全文字列をExcelに出力する」に渡します。
With Workbooks("パワーポイントの起動用マクロ.xlsm").Worksheets("Sheet1")
For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
Path = .Cells(i, 1).Value
Call 表の全文字列をExcelに出力する(Path, xl_wbk) '対象のマクロを選択
Next i
End With
情報を抜き出したいパワーポイントは以下の通りとなります。
作成の都合上、今回はヘッダーの2個目「出力項目」で判定しております。
2.開いたパワーポイントのテーブルのヘッダーを判定する。
3.指定したヘッダーのテーブルをExcelに出力する。
ここからちょっと面倒になってきます。
今まではExcelだけで済んでいたのが、PowerPointも一緒にいじることになるからです。
とはいっても、形としては定義のところが多少変わるだけです。
そこさえ変えればロジック部分はそんなに違和感は生じないでしょう。
Public Function 表の全文字列をExcelに出力する(Path As String, xl_wbk As Object)
Dim ppapp As New PowerPoint.Application
Dim sld As PowerPoint.Slide
Dim shp As Object
Dim r As Long 'PowerPointの表の行番号
Dim c As Long 'PowerPointの表の列番号
Dim xl_app As Object
Dim xl_row As Long 'Excelの出力先行番号
ppapp.Visible = True
Set ppPR = ppapp.Presentations.Open(Path)
'出力先設定
xl_row = Cells(Rows.Count, 1).End(xlUp).Row + 1
'
For Each sld In ppPR.Slides
For Each shp In sld.Shapes
If shp.HasTable Then
With shp.Table
If .Columns.Count >= 2 Then
If .Cell(1, 2).Shape.TextFrame.TextRange = "出力項目" Then
For r = 2 To .Rows.Count
For c = 1 To .Columns.Count
xl_wbk.Worksheets(1).Cells(xl_row, c + 1).Value = _
.Cell(r, c).Shape.TextFrame.TextRange
Next c
xl_row = xl_row + 1
Next r
End If
End If
End With
End If
Next shp
Next sld
ppapp.Quit
Set pptapp = Nothing
Set 表の全文字列をExcelに出力する = xl_wbk
End Function
ではもう一度分解していきましょう。
まず面倒な型定義からです。
Public Function 表の全文字列をExcelに出力する(Path As String, xl_wbk As Object)
Dim ppapp As New PowerPoint.Application
Dim sld As PowerPoint.Slide
Dim shp As Object
Dim r As Long 'PowerPointの表の行番号
Dim c As Long 'PowerPointの表の列番号
Dim xl_app As Object
Dim xl_row As Long 'Excelの出力先行番号
ppapp、sld、shpはPowerPointの型定義です。
特に、ppappはExcelで使ったVBAからPowerPointに接続するためのオブジェクトです。
今後、以下のようにPowerPointの設定をいじるときはppappを指定することになります。
ppapp.Visible = True
開いたパワーポイントをppPRとして登録します。
Set ppPR = ppapp.Presentations.Open(Path)
つぎは書き込みファイルの最終行の次の行を取得します。
厳密に言うとA列の最終行の次の行ですね。
最後の+1がないと、テーブルの最後の行が上書きされてしまうので要注意な気がします。
何回か泣きました(´;ω;｀)。
'出力先設定
xl_row = Cells(Rows.Count, 1).End(xlUp).Row + 1
次は大詰め。
テーブルをすべてなめて、ヘッダーが一致したときにExcelに出力します。
'
For Each sld In ppPR.Slides
For Each shp In sld.Shapes
If shp.HasTable Then
With shp.Table
If .Columns.Count >= 2 Then
'ヘッダー「出力項目を判定」
If .Cell(1, 2).Shape.TextFrame.TextRange = "出力項目" Then
For r = 2 To .Rows.Count
For c = 1 To .Columns.Count
xl_wbk.Worksheets(1).Cells(xl_row, c ).Value = _
.Cell(r, c).Shape.TextFrame.TextRange
Next c
xl_row = xl_row + 1
Next r
End If
End If
End With
End If
Next shp
Next sld
このように出力されました。
出したくないものは内容として含まれていませんでした。