Импортировать информацию о счете из PDF в таблицу Excel с помощью VBA

Question

Я использовал работу других сообщений на Stack Overflow, чтобы найти решение моей проблемы. Мне нужно ввести информацию из более чем 1000 счетов-фактур в таблицу Excel. Мне удалось создать следующий код, однако код собирает правильную информацию, но продолжает перезаписывать ту же ячейку. В результате в таблице отображается только последний счет.

Не могли бы вы помочь мне определить, почему мне не удалось достичь своей цели. В идеале было бы создать новую строку для каждого счета в папке.

Sub GrabUsage()
Dim wb As Workbook
Dim path As String
Dim myFile As String
Dim myExtension As String
Dim myFolder As FileDialog
Dim OrdDelTotFName As String
Dim WApp As Object, WDoc As Object, WDR As Object
Dim ExR As Range
Dim r As Long

 'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
Set myFolder = Application.FileDialog(msoFileDialogFolderPicker)

With myFolder
    .Title = "Select A Target Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    path = .SelectedItems(1) & "\"
End With

' if the User select "Cancel"
NextCode:
path = path
If path = "" Then GoTo ResetSettings

' Target File Extension
myExtension = "*.pdf"

' Target Path with Ending Extention
myFile = Dir(path & myExtension)

 ' open Word application and load doc
Set WApp = CreateObject("Word.Application")

' Loop through all doc files in folder
Do While myFile <> ""
    Set WDoc = WApp.Documents.Open(Filename:=path & myFile)
    
Set ExR = Selection ' current location in Excel Sheet
 r = 1

    ' search Purchase order number
    WApp.Selection.HomeKey Unit:=6
    WApp.Selection.Find.ClearFormatting
    WApp.Selection.Find.Execute "Purchase Order No.: "
    WApp.Selection.MoveRight Unit:=1, Count:=1
    WApp.Selection.MoveRight Unit:=1, Count:=10, Extend:=1

    ' grab and put into excel
    Set WDR = WApp.Selection
    ExR(r, 1) = WDR ' place at Excel cursor

    ' search Order date
    WApp.Selection.HomeKey Unit:=6
    WApp.Selection.Find.ClearFormatting
    WApp.Selection.Find.Execute "Order Date: "
    WApp.Selection.MoveRight Unit:=1, Count:=1
    WApp.Selection.MoveRight Unit:=1, Count:=10, Extend:=1

    ' grab and put into excel
    Set WDR = WApp.Selection
    ExR(r, 2) = WDR ' place in cell right of Excel cursor

    'search requested delivery date
    WApp.Selection.HomeKey Unit:=6
    WApp.Selection.Find.ClearFormatting
    WApp.Selection.Find.Execute "Requested delivery date : "
    WApp.Selection.MoveRight Unit:=1, Count:=1
    WApp.Selection.MoveRight Unit:=1, Count:=10, Extend:=1

    ' grab and put into excel
    Set WDR = WApp.Selection
    ExR(r, 3) = WDR ' place in cell right of Excel cursor
    
       'search Total amount without tax:
    WApp.Selection.HomeKey Unit:=6
    WApp.Selection.Find.ClearFormatting
    WApp.Selection.Find.Execute "Total amount without tax: "
    WApp.Selection.MoveRight Unit:=1, Count:=1
    WApp.Selection.MoveRight Unit:=1, Count:=15, Extend:=1

    ' grab and put into excel
    Set WDR = WApp.Selection
    ExR(r, 4) = WDR ' place in cell right of Excel cursor
    
        ' go home and search Requisitioner
    WApp.Selection.HomeKey Unit:=6
    WApp.Selection.Find.ClearFormatting
    WApp.Selection.Find.Execute "Requisitioner: "
    WApp.Selection.MoveRight Unit:=1, Count:=1
    WApp.Selection.MoveRight Unit:=1, Count:=10, Extend:=1

    ' grab and put into excel
    Set WDR = WApp.Selection
    ExR(r, 5) = WDR ' place in cell right of Excel cursor
    r = r + 1
    
    WDoc.Close SaveChanges:=True
    myFile = Dir
    
    Loop
    
MsgBox "Finished scanning all files in Folder " & path

ResetSettings:

' Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Set wdApp = Nothing

End Sub