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

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

陥りがちな罠
GetTables
実際の動き

陥りがちな罠

　
例えばこんな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

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

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を開いている時でも呼び出せるようになるのでかなり便利なハズ。是非ご活用ください～(ᵔᴥᵔ)

個人用マクロブックを使って自分だけの右クリックメニューを作る【VBA/CommandBarControl】

ちょっとした操作のマクロで頻繁に使う関数はPERSONALに保存していつでも呼べる様にしているのですが、もっと簡単に呼べないかな～と思い右クリックからのメニューを自作してみた話し。