Opening a text file copying a specific set of info for a list off numbers

Try

Sub test()
    Dim myDir As String, fn As String, r As Range, x As String, txt As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = "" Then Exit Sub
    With CreateObject("VBScript.RegExp")
        .Pattern = "0 *TR(\d+)"
        For Each r In Sheets("Parts List").Range("a:a,c:c").SpecialCells(2)
            fn = Dir(myDir & r.Value & ".WPD\MPF1.MPF")
            If fn <> "" Then
                fn = myDir & r.Value & ".WPD\" & fn
                txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
                If .test(txt) Then r(, 2).Value = .Execute(txt)(0).submatches(0)
            End If
        Next
    End With
End Sub