Всем привет Прошу помочь В общем столкнулся с потребность сделать рабочий файл XLS для формирования отчетов нужно сохранять по типу "Название" + "Дата ГГГГ.ММ.ДД" но без VBA и макросов, решил сделать тупое копирования таблицы средствами формул и не знаю что дальше делать... да и сохраняет с VBA и макросами
Код
Sub СохранитьЛистВФайл()
On Error Resume Next
' название подпапки, в которую по-умолчанию будет предложено сохранить файл
Const REPORTS_FOLDER = "\"
' создаём папку для файла, если её ещё нет
MkDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
' выбираем стартовую папку
ChDrive Left(ThisWorkbook.Path, 1): ChDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
' вывод диалогового окна для запроса имени сохраняемого файла
Filename = "Проверка КВ-" + Format(Date, "yyyy/mm/dd") + ".xls"
' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
If VarType(Filename) = vbBoolean Then Exit Sub
' копируем активный лист (при этом создаётся новая книга)
Err.Clear: ActiveSheet.Copy: DoEvents
If Err Then Exit Sub ' произошла какая-то ошибка при попытке копирования листа
' убеждаемся, что активной книгой является копия листа
If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
' сохраняем файл под заданным именем в формате Excel 2003
ActiveWorkbook.SaveAs Filename, xlWorkbookNormal
' закрываем сохранённый файл
' (удалите следующую строку, если закрывать созданный файл не требуется)
ActiveWorkbook.Close False
End If
End Sub
Вы копируете лист, а это происходит уже вместе с формулами. У меня есть вот такое вот решение, вроде бы работает. Жалоб не было. Нету строчки с сохранением + у листа в новой книги стандартное название.
Код
Private Sub CommandButton1_Click()
Dim rngX As Range
Dim wbX As Workbook
Dim shX As Worksheet
Dim val
Dim zoo
Application.EnableEvents = False
zoo = ActiveWindow.Zoom
Set rngX = ActiveSheet.UsedRange
Set wbX = Workbooks.Add
Set shX = wbX.ActiveSheet
ActiveWindow.Zoom = zoo
val = rngX.Value
On Error Resume Next
ThisWorkbook.ActiveSheet.ShowAllData
On Error GoTo 0
rngX.Copy
shX.Paste
shX.PasteSpecial xlPasteColumnWidths
shX.Range(rngX.Address) = val
Application.CutCopyMode = xlCopy
wbX.Saved = True
Application.EnableEvents = True
End Sub
Банить меня нужно за такую "помощь". Мозг запудрил, а не помог. Мой макрос копирует данные с листа в новую книгу, но не сохраняет. В теории там не хватает 2-х строчек: 1. Задать нужное имя листу. ( что-то типа activeSheeet.name = thisWorkbook.activeSheet.name) 2. Сохранить (это у Вас есть).
В Вашем макросе нужно заменить в строке с SaveAs xlWorkbookNormal на xlWorkbookDefault и книга сохранится как xlsx. При её переоткрытии макросы пропадут. По части кнопок посмотрите тут: https://www.planetaexcel.ru/forum/?PAGE_NAME=read&FID=1&TID=49791. Если на листе нету нужных картинок и ещё каких-нить фигур, то можно просто:
Код
Dim IShape as Sape
For Each IShape In ActiveSheet.Shapes
IShape.Delete
Next
Wiss!!! СПАСИБО!!! помогла подсказка с заменой xlWorkbookNormal на xlWorkbookDefault я бы эту тонкость не обнаружил... Wiss, еще хочу спросить, а можно в моем коде исправить, что бы он сохранял не активную страницу, а допустим лист2 (TABL)? при условии что бы формулы не сохранялись, а только данные.
Сейчас думаю как не сохранять ту часть таблицы где нет данных
Sub мяу()
Dim awb As Workbook, sh As Worksheet, sFilename$
Application.DisplayAlerts = False
Application.CopyObjectsWithCells = False
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
If awb Is Nothing Then
sh.Copy
Set awb = ActiveWorkbook
Else
sh.Copy After:=awb.Sheets(awb.Sheets.Count)
End If
Next
sFilename = ThisWorkbook.FullName
Mid(sFilename, Len(sFilename), 1) = "x"
awb.SaveAs sFilename, xlOpenXMLWorkbook
awb.Close False
Application.DisplayAlerts = True
Application.CopyObjectsWithCells = True
Application.ScreenUpdating = True
End Sub
Всё гениальное просто. Спасибо. Запомню. Месяц назад с такой же проблемой бился. Такого решения не видел. Все предлагают: 1. Либо создавать новый лист и копировать ячейки + форматы. 2. Либо копировать лист и удалять кнопки и прочие объекты.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Ну спасибо, блин. Теперь оказывается, что в X=mid(...) и mid(...) =x за сочетанием букв "mid" понимаются вообще разные сущности. И как мне теперь с этим жить?!
P.S. В смысле реально спасибо и за науку и за ссылки. Схоронил.
Добрый день Долго не мог написать из-за работы... В общем я снова экспериментирую с кодом... где-то вляпал ошибку
Код
Sub мяу()
Dim awb As Workbook, sh As Worksheet, sFilename$
Application.DisplayAlerts = False
Application.CopyObjectsWithCells = False
Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
If awb Is Nothing Then
sh.Copy
Set awb = ActiveWorkbook
Else
sh.Copy After:=awb.Sheets(awb.Sheets.Count)
End If
Next
sFilename = ThisWorkbook.FullName + "-" + Format(Date, "yyyy/mm/dd") + ".xlsx"
Mid(sFilename, Len(sFilename), 1) = "x"
awb.SaveAs sFilename, xlOpenXMLWorkbook
awb.Close False
Application.DisplayAlerts = True
Application.CopyObjectsWithCells = True
Application.ScreenUpdating = True
End Sub
и сейчас пишет имя созданного файла Отчет.xlsx-2019.12.18.xlsx в строке FullName менял на Name ... совсем не помогло в общем в имя файла нужно корректно в конце вставить дату Прошу помощи, Заранее благодарю!