Sub Macro1()
Dim sPath As String, Txt As String, Rng As Range, sFile As String
    sPath = "D:\Downloads\" 'Путь соъранения
    Txt = "Слово" ' Искомое слово
    Set Rng = Sheets("Лист1").Range("A2:F10").Find(what:=Txt, LookIn:=xlFormulas, LookAt:=xlWhole)
    If Not Rng Is Nothing Then
        sFile = Rng.Offset(1, 0)
        ActiveWorkbook.SaveAs Filename:=sPath & sFile & ".xlsx"
    End If
End Sub