【ExcelVBA ・ WordVBA】PDFをWordで開いて、Excelに転記する

Sub PDFをWordで開いてコピペ()

    'WORD参照設定

    '警告を無視
    Application.DisplayAlerts = False

    Dim ws As Worksheet

    '最後尾にシートを追加
    Set ws = Worksheets.Add(After:=Sheets(Worksheets.Count))

    ws.Activate

    ws.Cells.Delete
    ws.Cells(1, 1).Select

    Dim file As String
    file = ThisWorkbook.Path & "\test-pdf\test_merged.pdf"

    Dim wdApp As Word.Application
    Dim wdDoc As Document

    'Wordを起動
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True

    'WordでPDFを開く
    Set wdDoc = wdApp.Documents.Open(file)

    'Wordの内容をExcelに貼り付け
    wdDoc.StoryRanges(wdMainTextStory).Copy
    ActiveSheet.Paste

    'Wordを閉じる
    wdDoc.Close
    wdApp.Quit savechanges:=wdDoNotSaveChanges

    ws.Cells(1, 1).Select
    Application.DisplayAlerts = True

End Sub

'WORD参照設定

Dim folderPath As String
folderPath = ThisWorkbook.Path
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")

'警告を無視
Application.DisplayAlerts = False

Dim ws As Worksheet

Dim wdApp As Word.Application
Dim wdDoc As Document

Dim file As String

'すべてのサブフォルダのパスを取得
For Each folder In fso.GetFolder(folderPath).SubFolders

    Debug.Print folder
    '最後尾にシートを追加
    Set ws = Worksheets.Add(After:=Sheets(Worksheets.Count))

    ws.Activate

    'Wordを起動
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = False

    'フォルダの各PDFを開いて変数に格納
    For Each fl In fso.GetFolder(folder).Files

        file = fl

        'WordでPDFを開く
        Set wdDoc = wdApp.Documents.Open(file)

        lastRow = Cells(Rows.Count, 1).End(xlUp).Row + 2

        Debug.Print lastRow

        'Wordの内容をExcelに貼り付け
        'wdDoc.StoryRanges(wdPrimaryHeaderStory).Copy
        'ActiveSheet.Paste
        wdDoc.StoryRanges(wdMainTextStory).Copy

        ws.Cells(lastRow, 1).PasteSpecial Paste:=xlPasteValues


        'Wordを閉じる
        wdDoc.Close

    Next
Next

wdApp.Quit savechanges:=wdDoNotSaveChanges
Application.DisplayAlerts = True

End Sub

Sub Word-Excel()
    '参照設定なしFSO
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    '参照設定なし Word
    Dim wd As Object
    Set wd = CreateObject("Word.Application")
    'wd.Visible = True
    Dim sh As Worksheet

    'Wordのメッセージを非表示
    'Application.DisplayAlerts = wdAlertsNone

    Set sh = ActiveSheet

    Dim fl
    Dim doc
    Dim i As Long, row As Long
    Dim strPlace As String, strPerson As String

    Const filePath As String = "C:\Users\***\Downloads\testtest"

    row = 1

    'フォルダの各Wordを開いて変数に格納
    For Each fl In fso.GetFolder(filePath).Files
        Set doc = wd.documents.Open(fl.Path, False, True) 'フルパス、メッセージ、読み取り専用
        Set tbls = doc.Tables

        'wordの各段落をチェックして、営業所名と担当者名を取得
        With doc

            For i = 1 To .Paragraphs.Count
                '「営業所」を含む文字列を取得
                If InStr(.Paragraphs(i), "営業所") > 0 Then
                    strPlace = .Paragraphs(i).Range.Text
                ElseIf InStr(.Paragraphs(i), "担当") > 0 Then
                    strPerson = .Paragraphs(i).Range.Text
                End If
            Next

            sh.Cells(row, 3).Value = tbls(1).Rows(2).Cells(1).Range.Text
            sh.Cells(row, 4).Value = tbls(1).Rows(2).Cells(2).Range.Text
            sh.Cells(row, 5).Value = tbls(1).Rows(2).Cells(3).Range.Text

        End With

        row = row + 1
        Range("A" & row).Value = strPlace
        Range("B" & row).Value = strPerson

        doc.Close
    Next

    wd.Quit
    'Application.DisplayAlerts = wdAlertsAll
    Set wd = Nothing
End Sub