Sub RenameAndMoveFile()
    Dim currentWB As Workbook
    Set currentWB = ThisWorkbook
    
    ' Текущий путь файла
    Dim srcPath As String
    srcPath = currentWB.FullName
    
    ' Целевая папка (поменяйте на свою)
    Dim destFolder As String
    destFolder = "C:\НоваяПапка\" ' укажите своё расположение
    
    ' Название файла без пути
    Dim fileName As String
    fileName = Right(srcPath, Len(srcPath) - InStrRev(srcPath, "\"))
    
    ' Регулярное выражение для поиска и удаления пробела и даты формата DD-MM-YYYY
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "\s\d{2}-\d{2}-\d{4}$" ' Пробел и дата в конце строки
    regex.Global = True
    
    ' Очистка имени файла
    Dim cleanedFileName As String
    cleanedFileName = regex.Replace(fileName, "")
    
    ' Полный путь к новому расположению файла
    Dim destPath As String
    destPath = destFolder & cleanedFileName
    
    ' Создаем целевую папку, если её нет
    If Dir(destFolder, vbDirectory) = "" Then
        MkDir destFolder
    End If
    
    ' Перемещаем и переименовываем файл
    On Error Resume Next
    Name srcPath As destPath
End Sub