トップ　>　汎用コード　>　PDFデータのExcel一括取り込み（指定フォルダの全PDF対象）

'+++ 宣言セクション +++　対応：Microsoft Office2013/2016/2019
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)

'///一般的なマクロより多くの時間を要します
Sub Get_Pdf_Data() '実行用マクロ　フォルダ内全てのPDFのテキストデータを取得
    
    Dim strDirPath As String
    
    'フォルダの選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then strDirPath = .SelectedItems(1)
    End With
    If Len(strDirPath) = 0 Then Exit Sub
    
    'フォルダの存在確認
    If Dir(strDirPath, vbDirectory) = "" Then Exit Sub
    
    'フォルダ内PDF検索
    Call Search_PdfFiles(strDirPath)
    
End Sub

Private Sub Search_PdfFiles(ByVal strPath As String) 'フォルダ内PDF検索
    Dim strTarget  As String
    Dim strDirPath As String
    With Application
        strPath = strPath & .PathSeparator  'フォルダパスにフォルダ区切り文字追加
        strTarget = Dir(strPath & "*.pdf") 'フォルダ内のPDFを検索
        If strTarget = "" Then Exit Sub     'PDFがなければ終了
        Do
            Call Get_Data_Main(strPath, strTarget)  'テキスト取得メインルーチン
            strTarget = Dir()           '次のExcelブックを検索
        Loop Until strTarget = ""       'ブックがなければループから抜ける
    End With
    strTarget = Dir("")
End Sub

Private Sub Get_Data_Main(ByVal DirPath As String, ByVal FileName As String) 'データ取得メイン
    Dim objWord As Object
    Dim objDocs As Object
    Dim objTask As Object
    Set objWord = CreateObject("Word.Application") 'Wordインスタンス作成
    
    objWord.DisplayAlerts = False
    objWord.Visible = True 'Wordを非表示する場合はこの行をコメントにする
    Set objDocs = objWord.Documents.Open(DirPath & FileName) '開いたドキュメントの参照をオブジェクト型変数に格納
    FileName = Replace$(FileName, ".pdf", "", , , vbTextCompare)
    Do
        Call Sleep(50)
        For Each objTask In objWord.Tasks
            If 0 < InStr(1, objTask.Name, FileName, vbTextCompare) Then Exit Do 'Wordドキュメントが開いたら先に進む
        Next
    Loop
    objDocs.Content.Copy 'ドキュメントコピー
    With ThisWorkbook
        .Sheets.Add After:=ActiveSheet
        .ActiveSheet.Paste '「値のみ貼りつけ」は、この行をコメントにし、下の行のコメント外す
        '.ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
        .ActiveSheet.Range("A1").Copy
        Excel.Application.CutCopyMode = False
    End With
    objDocs.Close        'ドキュメントを閉じる
    objWord.DisplayAlerts = True
    objWord.Quit          'Wordアプリケーションを終了する
    Set objTask = Nothing 'オブジェクト変数破棄
    Set objDocs = Nothing  '
    Set objWord = Nothing '
End Sub