Try change to
Sub test()
    Dim myDir As String, fn As String, x
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myDir = .SelectedItems(1) & "\"
    End With
    If myDir = "" Then Exit Sub
    fn = Dir(myDir & "*.txt")
    Do While fn <> ""
        x = VLookLike(fn, Sheets(1).Cells(1).CurrentRegion.Columns(1))
        If x <> "" Then Name myDir & fn As myDir & x & " " & fn
         fn = Dir
    Loop
End Sub

Function VLookLike(txt As String, rng As Range) As String
    Dim i As Long, e, myName As String
    Dim a(), n As Long, x, temp, m As Object
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "^[A-Z][a-z]+"
        If .test(txt) Then
            myName = .Execute(txt)(0)
            For Each e In rng.Columns(1).Value
                .Pattern = "(\d+)[; -]*" & myName & "[ ;-]*(.+)"
                If .test(e) Then
                    n = n + 1
                    ReDim Preserve a(1 To 2, 1 To n)
                    a(1, n) = .Execute(e)(0).submatches(0): a(2, n) = 0
                    temp = .Execute(e)(0).submatches(1)
                    .Pattern = " *[;-]+ *"
                    temp = Replace(Application.Trim(.Replace(temp, " ")), " ", "|")
                    .Pattern = "\b(" & temp & ")\b"
                    For Each m In .Execute(txt)
                        a(2, n) = a(2, n) + Len(m)
                    Next
                End If
            Next
        End If
    End With
    If n > 0 Then
        With Application
            x = Application.Max(.Index(a, 2, 0))
            If x > 0 Then VLookLike = a(1, .Match(x, .Index(a, 2, 0), 0))
        End With
    End If
End Function