Sub save_As_Word_3()
    Application.ScreenUpdating = False
    Dim curWb As Workbook, newWb As Workbook, wdApp As Object, wdDoc As Object, folderName As String
    folderName = createFolder("Рапорт", ThisWorkbook.Path)
    ' Текущий файл
    Set curWb = ThisWorkbook
    ' Новая копия
    Workbooks.Add
    Set newWb = ActiveWorkbook
    
    ' Копируем все ячейки в новую книгу - значения, форматы
    curWb.Sheets("Рапорт").Cells.Copy
    With newWb.ActiveSheet.Cells
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
        Range("A1").Select
    End With

    ' Имя сохранения из ячейки B1
    saveName = curWb.Sheets("Информация").Range("B1")
    
    ' Создаём документ Word
    Set wdApp = CreateObject("Word.Application")
    wdApp.Documents.Add
    Set wdDoc = wdApp.ActiveDocument
    ' С копии листа Учсуд скопируем используемый диапазон
    ActiveSheet.UsedRange.Copy
    wdDoc.Range.Paste
    '  Word'e другая модель сохранения, сначала перейдем в папку
    wdApp.ChangeFileOpenDirectory folderName
    ' Сохраним
    wdDoc.SaveAs Filename:=saveName & ".docx", FileFormat:=wdFormatXMLDocument
                
     ' К закрытию все причешем
    Application.CutCopyMode = False
    wdDoc.Close
    wdApp.Quit
    newWb.Close
    Application.ScreenUpdating = True
End Sub

' Проверить (и создать при необходимости папку, вернуть путь
Function createFolder(folderName As String, Optional folderPath As String = "") As String
    Dim fso As Object, folderFullPath As String
    If folderPath = "" Then folderPath = ThisWorkbook.Path
    folderFullPath = folderPath & "\" & folderName & "\"
    Set fso = CreateObject("scripting.filesystemobject")
    
    If Not fso.FolderExists(folderFullPath) Then
        fso.createFolder (folderFullPath)
    End If
    createFolder = folderFullPath
End Function