Compare files in folder with comments in sheet, rename files based on conditions

Hi sans

Not the most elegant....

Option Explicit

Sub Rename_Files()
Dim Fso As Object, objFolder As Object, File As Object
Dim Path As String, Name As String, Num As String, NewName As String
Dim cell As Range, x As Long, Word
Application.ScreenUpdating = False
Path = ThisWorkbook.Path & "\Txt Folder\" 'change Txt Folder to name of folder housing txt files
Set Fso = CreateObject("Scripting.filesystemobject")
Set objFolder = Fso.GetFolder(Path)
For Each File In objFolder.Files
    Name = Left(File.Name, (InStrRev(File.Name, ".", -1, vbTextCompare) - 1))
    With ActiveSheet
        For Each cell In .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
            Num = Left(cell, Application.Find(" ", cell))
            Word = Split(cell, " ")
            For x = 0 To UBound(Word)
                If Name Like "*" & Word(x) & "*" Then
                    NewName = Num & Name
                    GoTo nxt
                End If
            Next x
        Next cell
    End With
nxt:
    File.Name = NewName & ".txt"
Next File
Application.ScreenUpdating = True
End Sub