VBAを用いて複数のパワーポイントから対象の表の内容をエクセルに抽出する

初投稿です。

このプログラムも正直もっといい方法があったような気もしますので、もっとこうしたらみたいな案があったらコメントでご指導ください。
　 
この記事は以下の内容で提供しています。
#####作成目的
複数のパワーポイントにて挿入しているテーブルの内容をエクセルに出力すること
####作成環境

- Excel(Microsoft Office Home and Business 2013)
- Windows10

#####注意事項
本VBAでは、以下の前提でパワーポイントの表を出力しています。

- テーブルにヘッダーがついている。（ex：出力項目 ）
- テーブルのカラム項目が固定している。
- ヘッダーがユニークである。

テーブルにヘッダーが入ってなかったり、カラム数が変動している場合は抽出できません。
別のものを探してください。

  
#ソース
「パワーポイントのファイルを開く」と「表の全文字列をExcelに出力する」の二つのメソッドに分けていますが、これは「パワーポイントのファイルを開く」を他のプログラムでも使いまわすためです。
Call ～と 渡す引数さえ変更すれば他のプログラムでも流用できます。

```vb
    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先のパワーポイントを開く。
![起動用マクロ.jpg](https://qiita-image-store.s3.amazonaws.com/0/319265/511c7436-1c70-e8e2-5be4-f51759939417.jpeg)
こちらがパワーポイントを起動させるためのファイルです。
A列に、絶対参照形式でURLを入力しています。
（今回、途中までパワーポイント側に実装しようと思っていたため、拡張子がpptmになっておりますがpptxでももちろん大丈夫です。）


---
```vb
    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
```
では分解していきます。


```vb
    Sub パワーポイントのファイルを開く()

    Dim Path As String
    Dim xl_wbk As Object
```
ここの部分は定義の箇所です。そんなに気にしなくても大丈夫です。
Pathとかxl_wbkとかの名称を変更しても以下の部分を変更すれば、特に影響は出ません。
As以降だけ気を付ければ大丈夫です。

```vb
    Set xl_wbk = Workbooks.Add '新規ワークブック追加 
```

ここの箇所では、Excelで新規のブックを作成しxl_wbkという名前を登録しています。
以降、xl_wbkは書き込みファイルをさします。もし書き込みたいファイルが決まっている場合、以下のように書き換えれば指定できます。（書き込みたいファイル：hogehoge.xlsx）

```vb
    Set xl_wbk = Workbooks("hogehoge.xlsx")
```

A列に書かれた開きたいパワーポイントのURL（Path）と書き込みファイル（xl_wbk）を
ファンクション「表の全文字列をExcelに出力する」に渡します。

```vb
    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個目「出力項目」で判定しております。
![対象ぱわぽ1.jpg](https://qiita-image-store.s3.amazonaws.com/0/319265/cb42aa5d-ec1b-e0ab-8546-59b87177c992.jpeg)
![対象ぱわぽ2.jpg](https://qiita-image-store.s3.amazonaws.com/0/319265/4bd9065c-0d51-8957-2aef-bc4a733c85bc.jpeg)

### 2.開いたパワーポイントのテーブルのヘッダーを判定する。
### 3.指定したヘッダーのテーブルをExcelに出力する。
ここからちょっと面倒になってきます。
今まではExcelだけで済んでいたのが、PowerPointも一緒にいじることになるからです。
とはいっても、形としては定義のところが多少変わるだけです。
そこさえ変えればロジック部分はそんなに違和感は生じないでしょう。

```vb
    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
```

ではもう一度分解していきましょう。
まず面倒な型定義からです。

```vb
    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を指定することになります。

```vb
    ppapp.Visible = True
```

開いたパワーポイントをppPRとして登録します。

```vb
    Set ppPR = ppapp.Presentations.Open(Path)
```
 
つぎは書き込みファイルの最終行の次の行を取得します。
厳密に言うとA列の最終行の次の行ですね。
最後の+1がないと、テーブルの最後の行が上書きされてしまうので要注意な気がします。
何回か泣きました(´;ω;｀)。

```vb
    '出力先設定
    xl_row = Cells(Rows.Count, 1).End(xlUp).Row + 1
```

次は大詰め。
テーブルをすべてなめて、ヘッダーが一致したときにExcelに出力します。

```vb
    '
    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
```
　
![実行結果.jpg](https://qiita-image-store.s3.amazonaws.com/0/319265/76c64d90-d11f-cfee-8a64-24ef3f2d78e3.jpeg)

このように出力されました。
出したくないものは内容として含まれていませんでした。