PDFファイルからエクセルファイル変換

Sub Get_Pdf_Data1() '実行用マクロ　フォルダ内全ての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インスタンス作成

Application.DisplayAlerts = False
'MLEvalString ("myLongOperation")

objWord.DisplayAlerts = False
objWord.Visible = True 'Wordを非表示する場合はこの行をコメントにする
Set objDocs = objWord.Documents.Open(DirPath & FileName) '開いたドキュメントの参照をオブジェクト型変数に格納
FileName = Replace$(FileName, ".pdf", "", , , vbTextCompare)
Do
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 '
Application.DisplayAlerts = True

End Sub

Sub Get_Pdf_Data2() '実行用マクロ　フォルダ内全ての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)

MsgBox "終了"

End Sub

Private Sub Search_PdfFiles(ByVal strPath As String) 'フォルダ内PDF検索
Dim strTarget As String
Dim strDirPath As String
Dim myFSO As New FileSystemObject
Dim myfolder As Folder
Dim myfiles As Files
Dim myfile As File

Set myfolder = myFSO.GetFolder(strPath)
Set myfiles = myfolder.Files
For Each myfile In myfiles
If myfile.Name Like "*.pdf" Then
strTarget = myfile.Name
Call Get_Data_Main(strPath, strTarget) 'テキスト取得メインルーチン
End If
Next

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
Dim WSheetName As String

Set objWord = CreateObject("Word.Application") 'Wordインスタンス作成

Application.DisplayAlerts = False

objWord.DisplayAlerts = False
objWord.Visible = True 'Wordを非表示する場合はこの行をコメントにする
Set objDocs = objWord.Documents.Open(DirPath & "\" & FileName) '開いたドキュメントの参照をオブジェクト型変数に格納
WSheetName = Replace(FileName, ".pdf", "")
FileName = Replace$(FileName, ".pdf", "", , , vbTextCompare)
Do
For Each objTask In objWord.Tasks
If 0 < InStr(1, objTask.Name, FileName, vbTextCompare) Then Exit Do 'Wordドキュメントが開いたら先に進む
Next
Loop

Dim newBookName As String
Dim newBookPath As String
Dim newBook As Workbook

'新しいファイルの名前を指定
newBookName = WSheetName

'新しいファイルのフルパスを設定
newBookPath = DirPath & "\" & newBookName & ".xlsx"

'指定したパスにファイルが作成済でないかを確認。
If Dir(newBookPath) = "" Then
'新しいファイルを作成
Set newBook = Workbooks.Add
Else
'既に同名のファイルが存在する場合はメッセージを表示
MsgBox "既に" & newBookName & "というファイルは存在します。"
Exit Sub
End If

objDocs.Content.Copy
With newBook
.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

newBook.SaveAs newBookPath
newBook.Close SaveChanges:=True

objDocs.Close 'ドキュメントを閉じる
objWord.DisplayAlerts = True
objWord.Quit 'Wordアプリケーションを終了する
Set objTask = Nothing 'オブジェクト変数破棄
Set objDocs = Nothing '
Set objWord = Nothing '
Application.DisplayAlerts = True

End Sub