Private Sub Сохранение()
    Dim wb1 As Workbook
    On Error Resume Next
    Const REPORTS_FOLDER = "Отчёты по тепловым счетчикам\"
    MkDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
    ChDrive Left(ThisWorkbook.Path, 1): ChDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
    Filename = Application.GetSaveAsFilename("отчёт.xls", "Отчёты Excel (*.xls*),", , _
    "Введите имя файла для сохраняемого отчёта", "Сохранить")
    If VarType(Filename) = vbBoolean Then Exit Sub
    Filename = Filename & "xls"
    On Error Resume Next
    Range("A1:AA9999").Copy
    Set wb1 = Workbooks.Add
    With wb1.Sheets(1).Range("A1")
        .PasteSpecial (xlPasteColumnWidths)
        .PasteSpecial (xlPasteValues)
        .PasteSpecial (xlPasteFormats)
    End With
    wb1.SaveAs Filename, xlWorkbookNormal
End Sub