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
Bookmarks