Excel макрос сохранить листья

Макрос сохранения листа Excel в файл

Данный макрос позволяет упростить процедуру сохранения активного листа в книге Excel в отдельный файл.

Для использования этого макроса на любом листе в книге Excel создайте кнопку, и назначьте ей макрос СохранитьЛистВФайл.

При запуске макроса (нажатии кнопки) будет выведено диалоговое окно выбора имени для сохраняемого файла, после чего текущий лист будет сохранён под заданным именем в выбранной папке.

Сохранение производится в формате XLS (формат Excel 2003)
Если пользователь отказался от ввода имени файла (нажал клавишу ESC или кнопку «Отмена» в диалоговом окне),
то сохранения листа в файл не происходит.

PS: Кто-то может сказать, что для сохранения листа в файл в объектной модели Excel есть метод SaveAs, применимый к объекту Worksheet.

Но, как ни странно, выполнение кода ActiveSheet.SaveAs » « приводит к сохранению книги целиком, что равносильно использованию кода ActiveWorkbook.SaveAs » «

Почему этот метод сохранения работает так нелогично — лично мне не понятно (видимо, Microsoft что-то там перемудрил)

Комментарии

Доброго времени! Очень полезный макрос, спасибо! Подскажите пожалуйста, что нужно изменить что бы сохранялись несколько листов?

Здравствуйте, макрос отлично работает, но подскажите как подправить чтобы в в файл «отчет» сохранялось два листа? Например: Лист1 и Лист9. Я сам в макросах пока еще плохо разбираюсь. Спасибо.

Спасибо. Разобрался. Нашёл ошибки в библиотеках.)

Спасибо. Всё запустил, но не работает. Пишет не найден проект или библиотека. Простите, не уточнил, поменял ещё саму систему (был XP стал Win7 x64).
Вот мой код:
Private Sub CommandButton2_Click()
On Error Resume Next
Const REPORTS_FOLDER = «C:Users. . . »
MkDir ThisWorkbook.Path & «» & REPORTS_FOLDER
ChDrive Left(ThisWorkbook.Path, 1): ChDir ThisWorkbook.Path & «» & REPORTS_FOLDER
FileName = [b8] & «_» & [b6] & «_» & [b4] & «_» & Format([b2], «DDMMMMYY») & «_» & [c2] & «.xlsx»
Err.Clear: Worksheets(Array(. «, «. «)).Copy: DoEvents
If Err Then Exit Sub
If ActiveWorkbook.Worksheets.Count = 2 And ActiveWorkbook.Path = «» Then
ActiveWorkbook.SaveAs FileName, xlWorkbookNormal
ActiveWorkbook.Close False
End If
End Sub

Убедитесь, что макросы вообще включены в настройках Excel.
Перед запуском файла с макросами, необходимо выполнить следующее:

> найти файл с макросами в папке
> щелкнуть правой кнопкой мыши на файле — Свойства — Разблокировать — ОК
> и только после этого запускать

Перешёл с 2007 на Office 2016, перестали работать макросы. И этот. (((

Добрый день, подскажите, пожалуйста, что надо изменить в макросе, чтобы:
1. Он копировал не весь лист целеком, а только диапазон ВИДИМЫХ ячеек (A1:L50), т.к. этот диапазон только часть отфильтрованного списка.
2. Он копировал только значения, без формул ячеек.

Здравствуйте, Алексей
Да, можно такое сделать, — могу написать макрос под заказ.

Здравствуйте, Игорь.
Подскажите, пожалуйста, возможно ли такое, чтобы Лист можно было сохранять не единожды (по имени в одной ячейке) а сославшись на какой-либо диапазон ячеек. Есть потребность сделать в конкретной папке количество файлов соответствующее количеству дней в месяце(отчет на каждый день). Если в диапазоне ячеек указать даты месяца и по нажатию макрос сохранял бы, файлы с именем Даты.

Можете написать макрос под заказ? Мне надо до понедельника

Напишите ваши контакты, есть несколько задач.

Дмитрий, можем сделать вам макрос под заказ.
Оформляйте заказ, прикрепляйте файл (в который надо встроить макрос), и подробно описывайте, что куда в каком виде и под каким именем сохранять.

Дело в том, что в книге порядка 20-30 листов и каждый лист необходимо сохранить в отдельные папки, соответствующие имени листа.

Дмитрий, а куда уж проще-то. вы нажимаете одну кнопку «Печать», и получаете готовый файл JPG
Зачем ещё-то упрощать.
Можно, конечно, и макрос под заказ написать
Если в формат BMP (или EMF) картинку сохранять — то макрос несложный, если в формат JPG — то макрос сложнее будет (и дороже)
Но я бы на вашем месте не стал изобретать велосипед, а оставил бы все как есть.

Сохраняю листы в JPEG формате, при помощи виртуального принтера «universal document converter» возможно ли упростить процедуру сохранения активного листа?

Здравствуйте, Игорь. Будьте любезны, взгляните на код. Основная часть была взята с другого сайта, часть с Вашего. Суть такая: на первом листе исходные данные и кнопка, на третьем — расчеты с формулами. Необходимо чтобы при нажатии кнопки создавалась папка «Двери» в текущей папке, где лежит этот файл (а если она есть, то сохранялось в нее), а имя файла бралось с листа 1 из ячеек a17 & b17. Сохраняться должен третий лист (он скрыт), формулы на нем заменить на значения. После сохранения новая книга закрывается и выводится сообщение об удачном сохранении файла с именем из ячеек a17 & b17. Сам я методом тыка пытался воплотить это, но лист не хочет сохраняться с указанным именем (используется имя по умолчанию «Книга 2. Книга 3. ). Также непонятно мне как сделать чтобы выскакивало сообщение о результате сохранения. Подскажите пожалуйста.

On Error Resume Next
Const REPORTS_FOLDER = «Двери»
‘ название подпапки, в которую по-умолчанию будет предложено сохранить файл

MkDir ThisWorkbook.Path & «» & REPORTS_FOLDER
‘ создаём папку для файла, если её ещё нет

ChDrive Left(ThisWorkbook.Path, 1): ChDir ThisWorkbook.Path & «» & REPORTS_FOLDER
‘ выбираем стартовую папку

Filename = Range(«a17») & («b17») & «.xls»
‘ вывод диалогового окна для запроса имени сохраняемого файла

If VarType(Filename) = vbBoolean Then Exit Sub
‘ если пользователь отказался от выбора имени файла — отменяем сохранение листа в файл

Dim Ar(), ArAll&(), Sh As Excel.Worksheet, n

Select Case Sheets(1).[Условие]
Case 1
Ar = Array(3)
Case Else
End Select

ReDim Preserve ArAll(0 To ThisWorkbook.Worksheets.Count — 1)
For Each Sh In ThisWorkbook.Worksheets
ArAll(n) = Sh.Index
n = n + 1
Next
ThisWorkbook.Worksheets(ArAll).Copy
Application.Volatile
Application.Calculate
Application.ScreenUpdating = False
For Each n In Ar
With ActiveWorkbook.Worksheets(n).UsedRange.Cells
.Value = .Value
End With
Next
Erase ArAll: n = 0
ReDim Preserve ArAll(0 To ThisWorkbook.Worksheets.Count — 1 — (UBound(Ar) + 1))
For Each Sh In ActiveWorkbook.Worksheets
If IsError(Application.Match(Sh.Index, Ar, 0)) Then
ArAll(n) = Sh.Index
n = n + 1
Else: If Sh.Visible = False Then Sh.Visible = True
End If
Next
ActiveWorkbook.Sheets(Ar(0)).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Worksheets(ArAll).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Dialogs(xlDialogSaveAs).Show

ActiveWorkbook.Close False
End Sub

Dim WB As Workbook
Dim ind As Integer
ind = ActiveSheet.Index
Application.DisplayAlerts = False
Set WB = Workbooks.Add
Dim li As Long
Application.DisplayAlerts = False
ind = 3
For n = ind To 2 Step -1
ThisWorkbook.Sheets(n).Copy Before:=WB.Sheets(1)
Next

pdfFilename = Application.DefaultFilePath & Application.PathSeparator & «имя файла» & Range(«D9»).Value & «.pdf»
WB.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=pdfFilename, OpenAfterPublish:=False

При этом файл создается с названием «имя файла.pdf» начисто игнорируя содержимое ячейки указанной.

Вот макрос, который сохраняет без ограничения 255-ти символов в ячейке:

Источник

Excel макрос сохранить листья

Часто встречал вопрос: — «Как сохранить лист в отдельный файл?»
Вот пример сохранения сразу несколько листов и по одному.

Корректировка и сокращение макросов приветствуется.

Часто встречал вопрос: — «Как сохранить лист в отдельный файл?»
Вот пример сохранения сразу несколько листов и по одному.

Корректировка и сокращение макросов приветствуется. Wasilich

Сообщение Часто встречал вопрос: — «Как сохранить лист в отдельный файл?»
Вот пример сохранения сразу несколько листов и по одному.

Корректировка и сокращение макросов приветствуется. Автор — Wasilich
Дата добавления — 28.10.2013 в 22:20

AndreTM

Дата: Вторник, 29.10.2013, 02:38 | Сообщение № 2

Skype: andre.tm.007 Donate: Q iwi: 9517375010 RAN Дата: Вторник, 29.10.2013, 04:19 | Сообщение № 3 Быть или не быть, вот в чем загвоздка! Ответить AndreTM Дата: Вторник, 29.10.2013, 04:44 | Сообщение № 4 Skype: andre.tm.007 Donate: Q iwi: 9517375010 Ответить Wasilich Дата: Вторник, 29.10.2013, 12:53 | Сообщение № 5 RAN Дата: Вторник, 29.10.2013, 22:27 | Сообщение № 6 Быть или не быть, вот в чем загвоздка! Ответить Wasilich Дата: Вторник, 29.10.2013, 23:40 | Сообщение № 7 Спасибо Андрей. Только Ник мой убери, это ж не для меня, и цифорки из кода тоже, иначе будут вопросы — «а зачем цифры?»! Вот еще варианты в примере, в т.ч. с макросом от AndreTM если он не возражает. Спасибо Андрей. Только Ник мой убери, это ж не для меня, и цифорки из кода тоже, иначе будут вопросы — «а зачем цифры?»! Вот еще варианты в примере, в т.ч. с макросом от AndreTM если он не возражает. Wasilich Спасибо Андрей. Только Ник мой убери, это ж не для меня, и цифорки из кода тоже, иначе будут вопросы — «а зачем цифры?»! Вот еще варианты в примере, в т.ч. с макросом от AndreTM если он не возражает. Автор — Wasilich Дата добавления — 29.10.2013 в 23:40 RAN Дата: Среда, 30.10.2013, 00:23 | Сообщение № 8 Любой каприз . Вариант для 1 листа [vba] Любой каприз . Вариант для 1 листа [vba] Быть или не быть, вот в чем загвоздка! Сообщение Любой каприз . Вариант для 1 листа [vba] RAN Дата: Среда, 30.10.2013, 00:33 | Сообщение № 9 Быть или не быть, вот в чем загвоздка! Ответить Wasilich Дата: Среда, 30.10.2013, 01:33 | Сообщение № 10 AndreTM Дата: Среда, 30.10.2013, 02:47 | Сообщение № 11 Skype: andre.tm.007 Donate: Q iwi: 9517375010 Ответить DAKRAY Дата: Четверг, 09.01.2014, 18:19 | Сообщение № 12 В приложении еще один простенький вариант сохранения. Изначальный код мне скинул antal10, переделал под свои нужды. П.С. Только вот никак не получается сделать так, чтобы модуль (функция) тоже копировался в новую книгу. Там у меня сумма прописью. Можно в принципе и значение только копировать, не обязательно с модулем — как проще. Если не сложно help подскажите!) В приложении еще один простенький вариант сохранения. Изначальный код мне скинул antal10, переделал под свои нужды. П.С. Только вот никак не получается сделать так, чтобы модуль (функция) тоже копировался в новую книгу. Там у меня сумма прописью. Можно в принципе и значение только копировать, не обязательно с модулем — как проще. Если не сложно help подскажите!) DAKRAY Сообщение Всем добрый. В приложении еще один простенький вариант сохранения. Изначальный код мне скинул antal10, переделал под свои нужды. П.С. Только вот никак не получается сделать так, чтобы модуль (функция) тоже копировался в новую книгу. Там у меня сумма прописью. Можно в принципе и значение только копировать, не обязательно с модулем — как проще. Если не сложно help подскажите!) Автор — DAKRAY Дата добавления — 09.01.2014 в 18:19 shebelme Дата: Понедельник, 06.10.2014, 08:05 | Сообщение № 13 Wasilich Дата: Среда, 08.10.2014, 00:21 | Сообщение № 14 200?’200px’:»+(this.scrollHeight+5)+’px’);»> Sub Лист_в_файл() ‘Сохранить текущий лист. Dim List$, iPath$ iPath = «D:Папкапапка» ‘ конкретный адрес для сохранения нового файла Application.ScreenUpdating = False Application.DisplayAlerts = False List = ActiveSheet.Name Sheets(List).Copy Sheets(List).UsedRange.Value = Sheets(List).UsedRange.Value Sheets(List).Buttons.Delete ‘Удаляем кнопки ‘Sheets(List).DrawingObjects.Delete ‘Удаляем все элементы ActiveWorkbook.SaveAs iPath & List ‘& «.xls» ActiveWorkbook.Close False Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox «Готово!» End Sub 200?’200px’:»+(this.scrollHeight+5)+’px’);»> Sub Лист_в_файл() ‘Сохранить текущий лист. Dim List$, iPath$ iPath = «D:Папкапапка» ‘ конкретный адрес для сохранения нового файла Application.ScreenUpdating = False Application.DisplayAlerts = False List = ActiveSheet.Name Sheets(List).Copy Sheets(List).UsedRange.Value = Sheets(List).UsedRange.Value Sheets(List).Buttons.Delete ‘Удаляем кнопки ‘Sheets(List).DrawingObjects.Delete ‘Удаляем все элементы ActiveWorkbook.SaveAs iPath & List ‘& «.xls» ActiveWorkbook.Close False Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox «Готово!» End Sub 200?’200px’:»+(this.scrollHeight+5)+’px’);»> Sub Лист_в_файл() ‘Сохранить текущий лист. Dim List$, iPath$ iPath = «D:Папкапапка» ‘ конкретный адрес для сохранения нового файла Application.ScreenUpdating = False Application.DisplayAlerts = False List = ActiveSheet.Name Sheets(List).Copy Sheets(List).UsedRange.Value = Sheets(List).UsedRange.Value Sheets(List).Buttons.Delete ‘Удаляем кнопки ‘Sheets(List).DrawingObjects.Delete ‘Удаляем все элементы ActiveWorkbook.SaveAs iPath & List ‘& «.xls» ActiveWorkbook.Close False Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox «Готово!» End Sub Ферхо Дата: Воскресенье, 07.12.2014, 14:28 | Сообщение № 15 Не претендую ни на что, просто я делаю так (возможно кому-то пригодится идея) 200?’200px’:»+(this.scrollHeight+5)+’px’);»> ‘сохранить лист в отдельном файле ‘sSheetName — имя сохраняемого листа (если такого нет — ни чего не делается) ‘sNewFileName — имя файла (если не задано — берется имя листа) ‘sNewPath — куда сохраняем, если не задано, в текущую ‘sRngDelList — если надо указываем диапазоны столбцов для удаления ‘bDelFurmula — если указано — удаляем формулы и ссылки ‘sSubRun — если нужна дополнительная обработка — укажим нужную процедуру Function fnSheetsSave(ByVal sSheetName As String, _ Optional ByVal sNewFileName As String = «», _ Optional ByVal sNewPath As String = «», _ Optional ByVal sRngDelList As String = «», _ Optional ByVal bDelFurmula As Boolean = False, _ Optional ByVal sSubRun As String = «») As Boolean Dim sFullFileName As String, arDelCol, iI As Integer, sCol As String Dim strPS As String: strPS = Application.PathSeparator If Not fnSheetsIsExist(sSheetName) Then Exit Function TRC.Pop «fnSheetsSave» TRC.INFO «Сохранение листа в отдельную книгу», eColorBloc If sNewFileName = «» Then sNewFileName = sSheetName mChkPath: ‘проверим и если что, сформируем путь If sNewPath = «» Then sNewPath = ActiveWorkbook.path & strPS Else If Right(sNewPath, 1) <> strPS Then sNewPath = sNewPath & strPS If Not fnPathIsExists(sNewPath) Then sNewPath = «» GoTo mChkPath End If End If ‘создаем полный путь к новому файлу sFullFileName = sNewPath & sNewFileName & IIf(fnGetFileExt(sNewFileName) = «», «.xls», «») ‘возможен долгий процесс, поэтому ‘дадим возможность поработать другим DoEvents On Error Resume Next ‘создаем копию листа. ‘создается новая книга и она становится активной ThisWorkbook.Sheets(sSheetName).Copy TRC.NOERROR «Лист скопирован в новую книгу (» & sSheetName & «)» If TRC.IFERROR(«ОШИБКА копирования листа (» & sSheetName & «) %1») Then GoTo lEXITfnSheetsSave ‘после возможно долгого процесса ‘дадим возможность поработать другим DoEvents If bDelFurmula = True Then ‘убираем ссылки и формулы ActiveSheet.Range(«A1»).CurrentRegion.Value = ActiveSheet.Range(«A1»).CurrentRegion.Value TRC.INFO «Формулы удалены» End If ‘однозначно убираем перенос по словам ActiveSheet.Range(«A1»).CurrentRegion.WrapText = False ‘если указаны столбцы на удаление — удалим их If sRngDelList <> «» Then arDelCol = Split(sRngDelList, » «) For iI = 0 To UBound(arDelCol) sCol = arDelCol(iI) ActiveSheet.Range(sCol).Delete Next iI TRC.INFO «Столбцы удалены (» & sRngDelList & «)» End If ‘если указана дополнительная функция для обработки — выполним ее If sSubRun <> «» Then Application.Run sSubRun TRC.INFO «Функция дополнительной обработки выполнена (» & sSubRun & «)» End If ‘сохраняем файл со всеми изменениями ActiveWorkbook.SaveCopyAs sFullFileName ActiveWorkbook.Close SaveChanges:=False TRC.NOERROR «Новая книга сохранена (» & sFullFileName & «)» If TRC.IFERROR(«ОШИБКА! Книга не сохранена (» & sFullFileName & «) %1») Then GoTo lEXITfnSheetsSave Не претендую ни на что, просто я делаю так (возможно кому-то пригодится идея) 200?’200px’:»+(this.scrollHeight+5)+’px’);»> ‘сохранить лист в отдельном файле ‘sSheetName — имя сохраняемого листа (если такого нет — ни чего не делается) ‘sNewFileName — имя файла (если не задано — берется имя листа) ‘sNewPath — куда сохраняем, если не задано, в текущую ‘sRngDelList — если надо указываем диапазоны столбцов для удаления ‘bDelFurmula — если указано — удаляем формулы и ссылки ‘sSubRun — если нужна дополнительная обработка — укажим нужную процедуру Function fnSheetsSave(ByVal sSheetName As String, _ Optional ByVal sNewFileName As String = «», _ Optional ByVal sNewPath As String = «», _ Optional ByVal sRngDelList As String = «», _ Optional ByVal bDelFurmula As Boolean = False, _ Optional ByVal sSubRun As String = «») As Boolean Dim sFullFileName As String, arDelCol, iI As Integer, sCol As String Dim strPS As String: strPS = Application.PathSeparator If Not fnSheetsIsExist(sSheetName) Then Exit Function TRC.Pop «fnSheetsSave» TRC.INFO «Сохранение листа в отдельную книгу», eColorBloc If sNewFileName = «» Then sNewFileName = sSheetName mChkPath: ‘проверим и если что, сформируем путь If sNewPath = «» Then sNewPath = ActiveWorkbook.path & strPS Else If Right(sNewPath, 1) <> strPS Then sNewPath = sNewPath & strPS If Not fnPathIsExists(sNewPath) Then sNewPath = «» GoTo mChkPath End If End If ‘создаем полный путь к новому файлу sFullFileName = sNewPath & sNewFileName & IIf(fnGetFileExt(sNewFileName) = «», «.xls», «») ‘возможен долгий процесс, поэтому ‘дадим возможность поработать другим DoEvents On Error Resume Next ‘создаем копию листа. ‘создается новая книга и она становится активной ThisWorkbook.Sheets(sSheetName).Copy TRC.NOERROR «Лист скопирован в новую книгу (» & sSheetName & «)» If TRC.IFERROR(«ОШИБКА копирования листа (» & sSheetName & «) %1») Then GoTo lEXITfnSheetsSave ‘после возможно долгого процесса ‘дадим возможность поработать другим DoEvents If bDelFurmula = True Then ‘убираем ссылки и формулы ActiveSheet.Range(«A1»).CurrentRegion.Value = ActiveSheet.Range(«A1»).CurrentRegion.Value TRC.INFO «Формулы удалены» End If ‘однозначно убираем перенос по словам ActiveSheet.Range(«A1»).CurrentRegion.WrapText = False ‘если указаны столбцы на удаление — удалим их If sRngDelList <> «» Then arDelCol = Split(sRngDelList, » «) For iI = 0 To UBound(arDelCol) sCol = arDelCol(iI) ActiveSheet.Range(sCol).Delete Next iI TRC.INFO «Столбцы удалены (» & sRngDelList & «)» End If ‘если указана дополнительная функция для обработки — выполним ее If sSubRun <> «» Then Application.Run sSubRun TRC.INFO «Функция дополнительной обработки выполнена (» & sSubRun & «)» End If ‘сохраняем файл со всеми изменениями ActiveWorkbook.SaveCopyAs sFullFileName ActiveWorkbook.Close SaveChanges:=False TRC.NOERROR «Новая книга сохранена (» & sFullFileName & «)» If TRC.IFERROR(«ОШИБКА! Книга не сохранена (» & sFullFileName & «) %1») Then GoTo lEXITfnSheetsSave Если очень хочется, то можно! Сообщение Не претендую ни на что, просто я делаю так (возможно кому-то пригодится идея) 200?’200px’:»+(this.scrollHeight+5)+’px’);»> ‘сохранить лист в отдельном файле ‘sSheetName — имя сохраняемого листа (если такого нет — ни чего не делается) ‘sNewFileName — имя файла (если не задано — берется имя листа) ‘sNewPath — куда сохраняем, если не задано, в текущую ‘sRngDelList — если надо указываем диапазоны столбцов для удаления ‘bDelFurmula — если указано — удаляем формулы и ссылки ‘sSubRun — если нужна дополнительная обработка — укажим нужную процедуру Function fnSheetsSave(ByVal sSheetName As String, _ Optional ByVal sNewFileName As String = «», _ Optional ByVal sNewPath As String = «», _ Optional ByVal sRngDelList As String = «», _ Optional ByVal bDelFurmula As Boolean = False, _ Optional ByVal sSubRun As String = «») As Boolean Dim sFullFileName As String, arDelCol, iI As Integer, sCol As String Dim strPS As String: strPS = Application.PathSeparator If Not fnSheetsIsExist(sSheetName) Then Exit Function TRC.Pop «fnSheetsSave» TRC.INFO «Сохранение листа в отдельную книгу», eColorBloc If sNewFileName = «» Then sNewFileName = sSheetName mChkPath: ‘проверим и если что, сформируем путь If sNewPath = «» Then sNewPath = ActiveWorkbook.path & strPS Else If Right(sNewPath, 1) <> strPS Then sNewPath = sNewPath & strPS If Not fnPathIsExists(sNewPath) Then sNewPath = «» GoTo mChkPath End If End If ‘создаем полный путь к новому файлу sFullFileName = sNewPath & sNewFileName & IIf(fnGetFileExt(sNewFileName) = «», «.xls», «») ‘возможен долгий процесс, поэтому ‘дадим возможность поработать другим DoEvents Источник Adblock detector