Public Sub RenameWb()
    Dim strOld As String
    Dim strPath As String
    Dim strName As String
    Dim wb As Excel.Workbook
    Dim ws As Excel.Worksheet
    Dim rng As Excel.Range
    
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Лист1")
    
    strOld = wb.FullName
    strPath = wb.Path
    strName = wb.Name
    
    Set rng = ws.Range("A:A").Find( _
      What:=Left(strName, Len(strName) -  4 ), _
      LookIn:=xlValues, _
      LookAt:=xlWhole, _
      MatchCase:=True)
    
    If Not rng Is Nothing Then
        wb.SaveAs strPath & "\" & rng.Offset( 0 ,  1 ).Value & " " & strName
        Kill strOld
    End If
End Sub