Sub Save_Copy_As1()
' Application.ScreenUpdating = False: Application.DisplayAlerts = False
Dim ShName As String, FName As String
Dim sSuff$: sSuff = " [" & Format(Now, "yyyy/mm/dd hh-mm'ss''") & "]" ' суффикс к имени файла копии - дата и время сохренения копии файла
'sSuff = "[2015-04-14]"
ShName = ActiveSheet.Name & sSuff
FName = Application.GetSaveAsFilename(InitialFileName:=ShName, _
FileFilter:="Excel Files (*.xls), *.xls", Title:="Выберите папку для сохранения")
ActiveWorkbook.Close saveChanges:=True, FileName:=FName
End Sub
Имя файла не подставляется, пробовал сокращать длину sSuff - сохраняет когда нет точек в дате, хотя в примере по ссылке сохраняет с точками, но как копию.
Квадратные скобки в имени файла недопустимы. Посмотрите код. Выбираете папку - сохраняется файл (НЕ КОПИЯ!!!) с добавлением даты и времени к имени
Код
Sub Save_Copy_As1()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
With .FileDialog(msoFileDialogFolderPicker)
If .Show = False Then Exit Sub
sFolder = .SelectedItems(1)
End With
End With
sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
BaseName = CreateObject("Scripting.FileSystemObject").GetBaseName(ThisWorkbook.Name)
FName = sFolder & BaseName & "_" & Format(Now, "yyyy/mm/dd-hh.mm.ss") & ".xlsm"
ActiveWorkbook.SaveAs Filename:=FName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Согласие есть продукт при полном непротивлении сторон
Sanja написал: Квадратные скобки в имени файла недопустимы.
Странная ситуация... макрос по ссылке из первого поста сохранял со скобками без проблем, но копию.
Пример навороченный вариант:
Код
Sub Save_Copy_As_Now()
'---------------------------------------------------------------------------------------
' Procedure : Save_Copy_As_Now
' Author : Alex_ST
' Topic_HEADER : Макрос Save_Copy_As
' Topic_URL : http://www.excelworld.ru/forum/3-1293-14737-16-1328619875
' DateTime : 07.02.12, 17:04
' Purpose : Сохранение копии активного файла с запоминанием папки для сохранения
' Notes : Путь сохранения копий хранится в коллекции .Names книги (в именованном диапазоне)
'---------------------------------------------------------------------------------------
Const sPath_in_Names = "Path4SaveCopyAs" ' имя элемента коллекции .Names, в котором должен храниться путь для сохранения копий файла
Dim sSuff$: sSuff = " [" & Format(Now, "yyyy/mm/dd hh-mm'ss''") & "]" ' суффикс к имени файла копии - дата и время сохренения копии файла
Dim FileName, sExp$, sDirPath$
With ActiveWorkbook
FileName = .Name ' например, "Книга1.xls"
sExp = "." & Split(FileName, ".")(UBound(Split(FileName, "."))) ' расширение файла вместе с точкой (например, ".xls")
FileName = Left(FileName, Len(FileName) - Len(sExp)) & sSuff & sExp ' например, "Книга1 [2012.02.06 15-24'39''].xls"
On Error Resume Next
sDirPath = .Names(sPath_in_Names).Value ' считать из коллекции .Names значение, ранее сохраненное под именем sPath_in_Names
If Err Then .Names.Add sPath_in_Names, .Path & "\": sDirPath = .Names(sPath_in_Names).Value ' если считать не удалось, значит путь ранее не задавался и он для первого раза задаётся равным ActiveWorkbook.Path
sDirPath = Split(sDirPath, """")(1) ' убрать из считанного значения =" в начале и " в конце
sDirPath = sDirPath & IIf(Right(sDirPath, 1) = "\", "", "\") ' на всякий случай (если имя было задано в ручную и при этом не верно - без слэша)
.Names(sPath_in_Names).Value = sDirPath ' запомнить путь сохранения копий в коллекции .Names под именем sPath_in_Names
REPEAT_:
FileName = Application.GetSaveAsFilename(InitialFileName:=sDirPath & FileName, _
FileFilter:="Excel Files (*" & sExp & "), *" & sExp & ", All Files (*.*),*.*", _
Title:="Сохранение копии файла") 'задать путь сохранения и имя копии файла в окне выбора
If VarType(FileName) = vbBoolean Then Exit Sub ' если нажали "Отмена", то FileName = False, если "Сохранить" - полный путь к файлу вместе с его именем
If FileName = .FullName Then MsgBox "Нельзя сохранить файл под именем открытой книги!", 16, "Ошибка": GoTo REPEAT_
sDirPath = Left(FileName, InStrRev(FileName, "\")) ' путь к папке сохранения копий без имени файла
.Names(sPath_in_Names).Value = sDirPath ' запомнить выбранный в диалоге путь в коллекции .Names под именем sPath_in_Names
.SaveCopyAs FileName
End With
End Sub
Function Replace_UnLegalChr$(ByVal sFileName$) ' замена не допустимых символов в именах файлов
Const sUnLegalChr$ = "/\:*?<>|""" ' символы, не допустимые в именах файлов Windows
Dim i%
For i = 1 To Len(sUnLegalChr)
sFileName = Replace(sFileName, Mid(sUnLegalChr, i, 1), "_")
Next i
Replace_UnLegalChr = sFileName
End Function
Изначально мне нужно сохранить лист как отдельный файл (с заданным именем в указанной папке) и оставить его открытым. С копированием листа и созданием новой книги проблем нет. Не могу сделать "красивое" сохранение.
Все верно. У меня есть Книга с несколькими листами, в один из них формирую отчет. Этот отчет и нужно сохранить как отдельную книгу и оставить открытым.
Из исходной книги я уже скопировал нужный лист в отдельный документ (в виде отчета без макросов, формул итд) его мне и нужно сохранить с нужным именем. Ваш Первый макрос не совсем подходит, тк он ссылается на книгу из которой запущен.
Пока решил очень коряво - но нужный результат получил. 0) копирую лист в отдельную книгу 1) сохраняю как копию (с квадратными скобками, таймстампом и др) 2) закрываю книгу 3) открываю только что сохраненный файл
Хочу просто сохранить и оставить активным на пункте 1)