Loop through Word docs in a directory, extract text, and append it to an Excel file

I want to extract a score from each Word document in a directory then append that score to an Excel workbook.

Nothing happens. No error is thrown.
The script did seem to work and printed the file name. I cancelled the process because I noticed something was wrong. The script hasn't worked since.

Sub DataExtraction()
Dim StrFile As String
StrFile = Dir("C:\Users\lones\Desktop\Business Documents")
Do While Len(StrFile) > 0
    Debug.Print StrFile
    StrFile = Dir
    Dim wdApp As Word.Application
    Dim wDoc As Word.Document
    Dim wRng As Word.Range
    Dim rngTest As Word.Range
    Dim rngEnd As Word.Range
    Dim strTheText As String
    Set wdApp = New Word.Application
    wdApp.Visible = True
    Const ExcelFile As String = "C:\Users\lones\Desktop\Business Data Extraction.xlsm"
    Set wDoc = wdApp.Documents.Open(Filename:=StrFile, ReadOnly:=True, AddToRecentfiles:=False)
    Set rngTest = wDoc.Range
    If rngTest.Find.Execute(FindText:="Test description... This user had ") Then
        Set rngEnd = wDoc.Range(rngTest.End, wDoc.Range.End)
        If rngEnd.Find.Execute(FindText:=" correct answers") Then
            Set wRng = wDoc.Range(rngTest.End, rngEnd.Start)
            wRng.Copy
        End If
    End If
    Dim LastRow As Long
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Debug.Print CStr(LastRow)
    Range("A" & CStr(LastRow)).Select
    ActiveWorkbook.ActiveSheet.Paste
Loop
End Sub

(would be mess as a comment)

I can't say your rest of code is correct but that Dir() looks weird to me (I am not a VBA guy, nor a VB but anyone may need to write some VBA unfortunately). Would you change that a bit:

Sub DataExtraction()
Dim StrFile As String
Dim Folder As String
Folder = "C:\Users\lones\Desktop\Business Documents"
StrFile = Dir(Folder + "*.docx")
Do While Len(StrFile) > 0
    Debug.Print StrFile
    
    Dim wdApp As Word.Application
    Dim wDoc As Word.Document
    Dim wRng As Word.Range
    Dim rngTest As Word.Range
    Dim rngEnd As Word.Range
    Dim strTheText As String
    Set wdApp = New Word.Application
    wdApp.Visible = True
    Const ExcelFile As String = "C:\Users\lones\Desktop\Business Data Extraction.xlsm"
    Set wDoc = wdApp.Documents.Open(Filename:=Folder + StrFile, ReadOnly:=True, AddToRecentfiles:=False)
    Set rngTest = wDoc.Range
    If rngTest.Find.Execute(FindText:="Test description... This user had ") Then
        Set rngEnd = wDoc.Range(rngTest.End, wDoc.Range.End)
        If rngEnd.Find.Execute(FindText:=" correct answers") Then
            Set wRng = wDoc.Range(rngTest.End, rngEnd.Start)
            wRng.Copy
        End If
    End If
    Dim LastRow As Long
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Debug.Print CStr(LastRow)
    Range("A" & CStr(LastRow)).Select
    ActiveWorkbook.ActiveSheet.Paste
    StrFile = Dir
Loop
End Sub