質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

89.65%

PDFからExcelにデータを抽出したい。

受付中

回答 0

投稿 編集

  • 評価
  • クリップ 4
  • VIEW 588

Kantakesan

score 6

前提・実現したいこと

PDFファイルから文字や数字を抽出してExcelのシートにデータとして表を作成したいのですが、どのように処理したらよろしいでしょうか。

当方、Excelマクロについても初心者であるため、以下の環境を提示させていただいていますが、情報不足でしたら追加で情報を載せたいと思います。
・処理するpdfは1ページを縦に2分割して記載されているデータ。しかし、.txtだと2分割されず順番に記載された形で出てくる。
・読み込みたいpdfは約1500枚あるため、個々のpdfから特定の事項を抽出してExcelシートに書き込めるようにしたい。

例) PDF
【ゲーム1】
0000
〇〇グループ
【参加者数】

合計 午前 午後1 午後2 夜間
20 5 10 0 4 1
20 5 10 0 4 1
男女計 40 10 20 0 8 2

参加の補助・諸制度
【プレイ時間】20時間/月
【追加料金】70,000円/月
【時間効率化の取り組み】行っている
【その他の諸制度】お弁当制度(ただしコアタイムにいる人(11:00~14:00)、昼休憩
(12:00~12:50))/短時間補助制度((補助が必要な方、もしくはそれに準ずる方)/半
日単位の追加ボーナス制度(午前(8:00~12:00)、午後(12:50~16:30))

⇒ Excel

コード 種別 名前 参加者数(男) 参加者数(女) 参加者数(合計) プレイ時間 追加料金 時間効率化の取り組み 半日単位の追加ボーナス制度
0000 ゲーム1 〇〇グループ 20 20 40 20.0 70000 1 1

・行っているの場合は「1」,無しの場合は「0」

念のため「.txt」だと以下のように表示されました。

【ゲーム1】
0000 
〇〇グループ
(中略)
【参加者数】 合計 午前 午後1 午後2 夜間 他
男 20 5 10 0 4 1 
女 20 5 10 0 4 1 
男女計 40 10 20 0 8 2 
参加の補助・諸制度
【プレイ時間】20.0時間/月
【追加料金】70,000円/月
【時間効率化の取り組み】行っている
【その他の諸制度】お弁当制度(ただしコアタイムにいる人(11:00~14:00)、昼休憩
(12:00~12:50))/短時間補助制度((補助が必要な方、もしくはそれに準ずる方)/半
日単位の追加ボーナス制度(午前(8:00~12:00)、午後(12:50~16:30))

・pdfはコピーした時に文字化けしない。
・Acrobat DCは購入済み。
・pdfファイルによって項目の回答の有無がある。

発生している問題・エラーメッセージ

実行時エラー13
型が一致しません
下から7行目のkingaku = kingaku + str(k + 2)に矢印が出ます。

該当のソースコード

'---コード1|フォルダ内のPDFファイルを1つずつ処理する
Option Explicit
Sub filecheck()
    Dim s1, s2, s3, filename, path, xmlpath
    Dim i, cmax
    Dim t1, t2
    Dim ws1, ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")

    Dim fs As FileSystemObject
    Dim basefolder As Scripting.Folder
    Dim destifolder, filepath As String

    Dim mysubfiles As Scripting.files
    Dim mysubfile As Scripting.file

    cmax = ws1.Range("A65536").End(xlUp).Row
    Set fs = New Scripting.FileSystemObject

    filepath = "C:/Users/名前/Documents/2019/"

    Set basefolder = fs.GetFolder(filepath)
    Set mysubfiles = basefolder.files


    For Each mysubfile In mysubfiles
        Debug.Print mysubfile.Name
        Debug.Print fs.GetExtensionName(mysubfile)
        Debug.Print fs.GetParentFolderName(mysubfile)

        If fs.GetExtensionName(path:=mysubfile) = "pdf" Then

            path = fs.GetParentFolderName(path:=mysubfile)
            xmlpath = xmlurl(mysubfile.Name, path)
            Call xml_parse(xmlpath)
        End If
    Next

End Sub
'---コード2|PDF毎にxml化する
Function xmlurl(filename, path)

    Dim objAcroApp As New Acrobat.AcroApp
    Dim objAcroAVDoc As New Acrobat.AcroAVDoc
    Dim objAcroPDDoc As Acrobat.AcroPDDoc
    Dim id
    Dim js
    Dim fullpath, savename As String

    fullpath = path & "\" & filename
    Debug.Print fullpath
    id = objAcroApp.Show 'Acrobatアプリケーションを起動する。
    id = objAcroAVDoc.Open(fullpath, "")
    Set objAcroPDDoc = objAcroAVDoc.GetPDDoc()
    'JavaScriptオブジェクトを作成する。
    Set js = objAcroPDDoc.GetJSObject
    savename = Replace(fullpath, ".pdf", "")
    js.SaveAs savename & ".xml", "com.adobe.acrobat.xml-1-00"

    'PDFファイルを変更無しで閉じます。
    id = objAcroAVDoc.Close(1)
    'Acrobatアプリケーションを終了する。
    id = objAcroApp.Hide
    id = objAcroApp.Exit
    'OLEを行うとAcrobatが不安定になるので、
    '一応オブジェクトを強制開放する。
    Set js = Nothing
    Set objAcroAVDoc = Nothing
    Set objAcroApp = Nothing

    xmlurl = savename & ".xml"

End Function

'---コード2|フォルダ内のPDFファイルだけを抽出
Sub xml_parse(ByVal xmlpath As String)
'Microsoft XML v6.0 を参照設定
    Dim XMLDocument As MSXML2.DOMDocument60
    Dim pElem As MSHTML.HTMLParaElement
    'Dim Doc As New XMLDocument
    Dim e As MSHTML.HTMLHtmlElement
    Dim ws1 As Worksheet

    Set ws1 = Worksheets("Sheet1")

    'MSXMLオブジェクトを生成し、xmlファイルをロード
    Set XMLDocument = New MSXML2.DOMDocument60

    'async = False → 読み込み終了後、次の処理をします(同期処理)
    'async = true →だと、読み込みが終わらなくても、次のステップへ(非同期処理)
    'VBAは非同期処理に対応していないので、async = Falseとします
    XMLDocument.async = False

    Dim strMsg As String
    Dim i, j, k, cmax, n As Long

    i = 0
    cmax = ws1.Range("A1048576").End(xlUp).Row
    'Doc.Load (xmlpath)
    XMLDocument.Load (xmlpath)

    If (XMLDocument.parseError.ErrorCode <> 0) Then 'ロード失敗

        strMsg = XMLDocument.parseError.reason      'エラー内容を出力

        MsgBox "ロードに失敗しました・・・" & vbCrLf & vbCrLf & strMsg, vbCritical

        Exit Sub

    End If

    ws1.Range("A" & cmax + 1).Value = cmax

    Dim objxml As Object
    Dim tmp As Variant

    For Each objxml In XMLDocument.getElementsByTagName("P")
        If InStr(objxml.XML, "請求番号") > 0 Then

        tmp = Split(objxml.Text, ":")

            For k = 0 To UBound(tmp)
                Debug.Print tmp(k)
                If InStr(tmp(k), "請求日") > 0 And InStr(tmp(k), "請求日の") = 0 Then
                    ws1.Range("B" & cmax + 1).Value = Left(tmp(k), Len(tmp(k)) - 3)

                ElseIf InStr(tmp(k), "支払期日") > 0 Then
                    ws1.Range("C" & cmax + 1).Value = Left(tmp(k), Len(tmp(k)) - 4)

                ElseIf InStr(tmp(k), "貴社コード") > 0 Then
                    ws1.Range("D" & cmax + 1).Value = Mid(tmp(k), 2, Len(tmp(k)) - 6)

                ElseIf InStr(tmp(k), "契約番号") > 0 Then
                    ws1.Range("E" & cmax + 1).Value = Mid(tmp(k), 2, Len(tmp(k)) - 5)

                ElseIf InStr(tmp(k), "支払方法") > 0 Then
                    ws1.Range("F" & cmax + 1).Value = Left(tmp(k), Len(tmp(k)) - 4)

                ElseIf k = UBound(tmp) Then
                    ws1.Range("G" & cmax + 1).Value = Mid(tmp(k), 2)

                End If
            Next

            tmp = Null

        End If
    Next

    j = 0

    Dim cnode, dnode As IXMLDOMNode
    Dim str() As Variant
    Dim tdvar As Variant

    Set cnode = XMLDocument.SelectSingleNode("//Table")

    j = 0
    For Each dnode In cnode.getElementsByTagName("TD")
        ReDim Preserve str(j)
        str(j) = dnode.Text
        Debug.Print j, str(j)
        j = j + 1
    Next

    Dim kingaku, zeigaku As Double
    Dim tekiyou As String
    kingaku = 0
    zeigaku = 0
    tekiyou = ""

    For j = 0 To UBound(str)
        k = 4 * j + 1
        If InStr(str(k), "ご請求") > 0 Then
            ws1.Range("H" & cmax + 1).Value = kingaku
            ws1.Range("I" & cmax + 1).Value = zeigaku
            ws1.Range("J" & cmax + 1).Value = kingaku + zeigaku
            ws1.Range("K" & cmax + 1).Value = tekiyou
            Exit For

        ElseIf InStr(str(k), "消費税") > 0 Then
            zeigaku = zeigaku + str(k + 2)

        ElseIf str(k) <> "" Then
            kingaku = kingaku + str(k + 2)
            If tekiyou = "" Then
                tekiyou = str(k)
            End If
        End If

    Next
End Sub

試したこと

・以下のサイトを参考にして、コードをコピぺしましたが、当然エラーは出てくるものの、さっぱり分からない状態です。ですので、後半はコピーしたまま、まだ手つかずの状態です。
https://www.fastclassinfo.com/entry/vba_pdf_text_extraction
・参照設定で、HTMLとAcrobatとMicrosoft Scripting Runtimeにはチェックを入れています。
・もし、pdfを他のツールで一気に(HTMLではなく)txt化して、「〇〇の文字の右横(あるいは下の行)の数字を取る」とか、「この文字があったら1を打つ」といったような設定ができるのではないかと考えましたが、これもわかりません。
・当方、初心者であるため、他の参考になるサイト等があればご教示いただけますと幸いです。
よろしくお願いいたします。

補足情報(FW/ツールのバージョンなど)

ここにより詳細な情報を記載してください。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正の依頼

  • Kantakesan

    2019/07/01 12:29

    >sazi様
    ご指摘ありがとうございます。
    無償では厳しいかもしれない案件であることをご教示いただきましてありがとうございます。
    またこちらの過失によりサイトについての問合せを見落としていました。
    早速ですが、問合せさせていただきました。
    >mts10806様
    質問サイトでどうにかなる案件であるかどうかがわからなかったため、大変貴重なアドバイスをありがとうございました。
    >複数のユーザー様
    「やってほしいことだけを記載した丸投げの質問」というご指摘ありがとうございます。
    確かにご指摘の通りであり、私自身の未熟さを痛感しましたところでございます。申し訳ございません。
    そこで、質問内容を「コードと共にご教示いただけますと」を「他の参考になるサイト等があるかどうか」の質問に変更させていただきました。

    キャンセル

  • shinobu_osaka

    2019/07/04 08:48

    ご自身でもいってらっしゃるようにCUIでPDFをテキスト抽出出来るソフト(たくさんありますがたとえばxdoc2txtとか)をVBAから呼び出してテキストファイル化して、それからエクセルのテキストファイル読み込み機能を使って…そこから処理すると簡単ではないかと。スマートではない?まぁ大体はいってるとは思いますが本来Windowsの標準状態で入ってない物を参照設定してるので一緒ですかね?

    キャンセル

  • 退会済みユーザー

    2019/07/06 17:37

    複数のユーザーから「やってほしいことだけを記載した丸投げの質問」という意見がありました
    「質問を編集する」ボタンから編集を行い、調査したこと・試したことを記入していただくと、回答が得られやすくなります。

まだ回答がついていません

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 89.65%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

同じタグがついた質問を見る