【Excel/VBA】PDFやWordから表データだけを抽出するマクロ

単純なコピペではレイアウトが崩れてしまい上手く行かないので、簡単に抽出できる方法を考えてみた。

陥りがちな罠

　
例えばこんなPDFがあるとします。

これの表データが欲しい場合、単純にCtrl+A 、Ctrl+C、Ctrl+VでExcelにコピッペしてしまいがちですが、そうするとこうなってしまいます↓

レイアウトがぶっ壊れてしまい、見るも無残な状態です。今回はこれを何とかしようって事で作ってみた。

GetTables

　
以下コピッペでOK。
※Microsoft Word 1X.0 Object Libraryの参照設定必要なので追加してください。

Sub GetTables()

    ' ダイアログボックス表示
    Dim PDFFile As String
    Dim WSH As Variant
    Set WSH = CreateObject("WScript.Shell")

    ' 始まりはデスクトップ
    ChDir WSH.SpecialFolders("Desktop")
    ' pdfファイル、単一のみ
    PDFFile = Application.GetOpenFilename(FileFilter:="pdf ファイル (*.pdf), *.pdf", MultiSelect:=False)
    
    ' キャンセルされた場合
    If VarType(PDFFile) = vbBoolean Then
        Exit Sub
    End If
    
    '現在のExcelのアクティブセル座標を取得しておく
    Dim wsActive As Worksheet
    Set wsActive = ActiveSheet
    Dim nRctiveRow As Long
    Dim nActiveCol As Long
    
    nRctiveRow = ActiveCell.Row
    nActiveCol = ActiveCell.Column

    ' Word起動
    Dim objApp As Object
    Dim objDoc As Word.Document
    Set objApp = CreateObject("Word.Application")
    Application.DisplayAlerts = False
    ' 非表示
    objApp.Visible = False
    Set objDoc = objApp.Documents.Open(PDFFile)

    Dim nPasteCnt As Long
    Dim objTable As Table
    nPasteCnt = objDoc.Tables.Count
    
    ' テーブルが複数存在する場合
    If nPasteCnt > 1 Then
       Dim vbRet As Integer
       vbRet = MsgBox("テーブルが複数存在します。全て抽出しますか？", vbYesNo + vbExclamation, "確認")
       ' Noの場合は最初の一つだけ
       If vbRet = vbNo Then
          nPasteCnt = 1
       End If
    End If
    
    Dim nTableCnt As Long
    Dim nRowCnt As Long
    Dim nColCnt As Long
    Dim nAllRowCnt As Long

    For nTableCnt = 1 To nPasteCnt
       ' テーブルセット
       Set objTable = objDoc.Tables(nTableCnt)
       
       For nRowCnt = 1 To objTable.Rows.Count
           For nColCnt = 1 To objTable.Columns.Count
               wsActive.Cells(nRctiveRow + nRowCnt - 1 + nAllRowCnt, nActiveCol + nColCnt - 1).Value = _
               Replace(objTable.Cell(nRowCnt, nColCnt).Range.Text, Chr(7), "")
           Next nColCnt
       Next nRowCnt
       ' 複数テーブルの場合は1行開けて入力する
       nAllRowCnt = nAllRowCnt + nRowCnt
       
    Next nTableCnt
    
    ' 後処理
    objDoc.Close
    objApp.Visible = False
    Set objApp = Nothing
    Application.DisplayAlerts = True
    
End Sub

PDFだろうと強制的にWORDで開くのがポイント。WORDで開く事でTablesによりテーブルだけぶち抜けるので綺麗にデータだけ持ってこれます。

複数テーブル有る時は、全部抽出するかメッセージを出し、NOなら最初の表のみ抽出。YESの場合は表と表の間を1行開けて抽出していきます。

実際の動き

複数テーブルはこんな感じ↓　テーブルが一個だけならダイアログは出ずそのまま抽出されます。

後はこれを個人用マクロブックにでも忍ばせておけば、いつどんなExcelを開いている時でも呼び出せるようになるのでかなり便利なハズ。是非ご活用ください～(ᵔᴥᵔ)