【EXCEL VBA】フォルダに入っている複数のpdfを開き、Excelシートに値の貼付けをしたい。

Question

実現したいこと

• フォルダに入っている複数のpdfを開き、Excelシートに値の貼付けをしたいです。
  --フォルダに保管されているpdfが20件あります。
  --このpdfを１つ開き、値のコピーをします。
  --Excelの"データシート"のA1行目に値を貼り付けします。
  --次のpdfを開き、値のコピーをし、B1行目に値の貼付けをします。
  --この一連の作業を自動で繰り返し、フォルダ内のpdfをすべて開いたら
  コピー作業は終了します。
  --PDFは手動で閉じます。

前提

Sub CopyPDFContentsToExcel()

    Dim folderPath As String
    Dim fileName As String
    Dim shellApp As Object
    Dim pdfText As String
    Dim excelSheet As Worksheet
    Dim currentColumn As Long
    Dim i As Long
    
    ' フォルダのパスを取得
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "PDFファイルが入ったフォルダを選択してください"
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
        Else
            Exit Sub ' フォルダを選択せずにキャンセルした場合、処理を終了
        End If
    End With
    
    ' Excelのシートを準備
    Set excelSheet = ThisWorkbook.Sheets("データシート")
    currentColumn = 1 ' 最初はA列からスタート
    
    ' フォルダ内のPDFファイルを一つずつ処理
    For i = 1 To 10
        fileName = Dir(folderPath & "\*.pdf")
        If fileName = "" Then
            Exit For ' ファイルがない場合は処理を終了
        End If
        
        ' PDFファイルを開く
        Set shellApp = CreateObject("Shell.Application")
        shellApp.Open (folderPath & "\" & fileName)
        
        ' 少し待つ（必要に応じて調整してください）
        Application.Wait Now + TimeValue("00:00:02")
        
        ' PDFファイルの内容をクリップボードにコピー
        Application.SendKeys "^a", True
        Application.SendKeys "^c", True
        
        ' クリップボードの内容を取得
        'pdfText = GetClipboardText
        
        ' Excelシートに貼り付け
        ActiveSheet.PasteSpecial Format:="Unicode テキスト", Link:=False, _
        DisplayAsIcon:=False, NoHTMLFormatting:=True
        
        ' PDFファイルを閉じる
        'On Error Resume Next ' エラーを無視して閉じる
        'shellApp.Windows.Find("Adobe Acrobat Reader").Close
        'On Error GoTo 0 ' エラー処理を元に戻す
        
        ' 次のファイルを処理
        currentColumn = currentColumn + 1
    Next i

End Sub

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

エラーメッセージは表示されません。
1枚目のpdfが開き、コピー後、データシートA1への値の貼付けはします。
2枚目以降pdfが開かず、作業も中断されません。

試したこと

' PDFファイルを閉じる
の部分がうまく動かないのでコメントとして残してあります。

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

EXCELは2019です。
自力での解決が難しく、ご教授お願い致します。
どうぞよろしくお願いします。

Answer 1

取り急ぎ、絶妙に説明が難しいので、修正したソースを貼り付けます。

Sub CopyPDFContentsToExcel()

    Dim folderPath As String
    Dim fileName As String
    Dim shellApp As Object
    Dim pdfText As String
    Dim excelSheet As Worksheet
    Dim currentColumn As Long
    Dim i As Long
    
    ' フォルダのパスを取得
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "PDFファイルが入ったフォルダを選択してください"
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
        Else
            Exit Sub ' フォルダを選択せずにキャンセルした場合、処理を終了
        End If
    End With
    
    '★ 少し待つ（必要に応じて調整してください）
    Application.Wait Now + TimeValue("00:00:02")
    
    '★1 Shellインスタンス化
    Set shellApp = CreateObject("Shell.Application")
    
    ' Excelのシートを準備
    Set excelSheet = ThisWorkbook.Sheets("データシート")
    currentColumn = 1 ' 最初はA列からスタート
    
    '★2 最初のPDFを取得
    fileName = Dir(folderPath & "\*.pdf")
    
    ' フォルダ内のPDFファイルを一つずつ処理
'    For i = 1 To 10
    Do While fileName <> "" '★3

'        fileName = Dir(folderPath & "\*.pdf")　★2
'        If fileName = "" Then
'            Exit For ' ファイルがない場合は処理を終了 ★3
'        End If
        
        ' PDFファイルを開く
'        Set shellApp = CreateObject("Shell.Application")   '★1
'        shellApp.Open (folderPath & "\" & fileName)  '★4
        shellApp.ShellExecute folderPath & "\" & fileName, 1  '★4
        
        ' 少し待つ（必要に応じて調整してください）
        Application.Wait Now + TimeValue("00:00:02")
        
        ' PDFファイルの内容をクリップボードにコピー
        Application.SendKeys "^a", True
        Application.SendKeys "^c", True
        
        ' クリップボードの内容を取得
        'pdfText = GetClipboardText
        
        '★4 PDFを閉じる
        Application.SendKeys "%{F4}", True
        
        '★ 少し待つ（必要に応じて調整してください）
        Application.Wait Now + TimeValue("00:00:02")
        
'        ' Excelシートに貼り付け ★5
'        ActiveSheet.PasteSpecial Format:="Unicode テキスト", Link:=False, _
'        DisplayAsIcon:=False, NoHTMLFormatting:=True
        
        '★5 Excelシートに貼り付け
        excelSheet.Cells(1, currentColumn).Select
        excelSheet.PasteSpecial Format:="Unicode テキスト", Link:=False, _
        DisplayAsIcon:=False, NoHTMLFormatting:=True
        
        
        ' PDFファイルを閉じる ★4
        'On Error Resume Next ' エラーを無視して閉じる
        'shellApp.Windows.Find("Adobe Acrobat Reader").Close
        'On Error GoTo 0 ' エラー処理を元に戻す
        
        '★2 次のファイルを取得
        fileName = Dir()
        
        ' 次のファイルを処理
        currentColumn = currentColumn + 1
        
'    Next i
    Loop

    '★1 解放
    Set shellApp = Nothing

End Sub

指定のフォルダ内のファイルは存在する数だけループできるようにしています（★2、★3）
Dir関数は、最初に開くフォルダとファイル指定をした後、Dir()で次のファイルになるため、Dir(folderPath & "*.pdf")を呼ぶと１つ目のファイルが常に取得されます。

PDFの部分はファイルによるので、待ち時間などは調整してください。
shellApp.ShellExecuteでPDFをアクティブにして、Alt+F4で閉じる手抜き処理していますので、他の操作をするとその操作しているアプリが閉じられたりします。

ざっくりですが、参考になれば幸いです。

Comments

[mari_0418]

実現したいこと、の通り動作しました。[Alt+F4]の処理についてのご説明もありがとうございます。いただいたコメントと、プログラムをよくみて問題点が解決できるように勉強したいと思います。ありがとうございました。

[crowmt]

無事に解決したようで何よりです。
色々調べて試されていることはソースで分かります。
おしい、あと少しという部分が散見されますので、後は理屈が整えば、ふとわかる瞬間が来ると思います。