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

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

Здравствуйте, макрос отлично работает, но подскажите как подправить чтобы в в файл "отчет" сохранялось два листа? Например: Лист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

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

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

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

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

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

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

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

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

Sub Ведомость_1()

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

WB.Close False

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

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

' Создание файла
    
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    Dim ShName As String, FName As String
    ShName = ActiveSheet.Name
    Workbooks.Add xlWBATWorksheet
    ThisWorkbook.Sheets(ShName).Cells.Copy ActiveWorkbook.Sheets(1).[a1]
    FName = Application.GetSaveAsFilename("Описание комплекта .xls", _
        FileFilter:="Excel Files (*.xls), *.xls", Title:="Выберите папку для сохранения")
 
    ActiveWindow.DisplayGridlines = False
 
    ActiveWorkbook.Close saveChanges:=True, Filename:=FName
 
   ' Конец создания файла

Спасибо огромное!!! если не затруднит
Почему то макрос долго отрабатывает, во впечатлениям на разрыве связей
если не трудно подправь
Sub AKT()
Sheets(Array("AKT1", "AKT2")).Select
Sheets("AKT1").Activate
Sheets(Array("AKT1", "AKT2")).Copy
ActiveWorkbook.BreakLink Name:= _
"C:\1\VSE.xlsm", Type:=xlExcelLinks
For Each cell In ActiveSheet.UsedRange.Cells
cell.Formula = cell.Value
Next cell
ChDir "C:\1"
ActiveWorkbook.SaveAs Filename:="C:\1\" & Range("A1") & ".xls" _
, FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.Close
End Sub

Доброго времени суток!
Подскажи пожалуйста как указать имя создаваемой папки с ячейки например(Лист3) (B1)
В моем случае
Const REPORTS_FOLDER = Cheets("InvKart").Range(R13C6)
ругается на .Range

Добрый день!
Спасибо за макрос.
Подскажите, пожалуйста, код, чтобы сохранение нового файла было в формате .xls без поддержки макроса и чтобы модуль с макросом там удалился.
прочитала комменты, есть подобная просьба (только формат XLSX) и решение:

"ActiveWorkbook.SaveAs Filename, xlOpenXMLWorkbook ' xlOpenXMLWorkbook = формат XLSX

а мне нужно .xls при этом без модуля в новом файле.
Спасибо.

Добрый день!
Спасибо, очень полезный макрос и очень полезный сайт.
Однако действительно существует проблема с обрезанием длинного текста в ячейках при сохранении листа (вопрос от Давида, 9 Ноя 2015 - 14:55, Excel 2003).
Можно ли это как-то решить в рамках данного макроса?

В ячейках Листа, который необходимо сохранить в файл, находится текст (около 1000 символов). После запуска макроса создается книга, но из текста в ячейке новой книги остаются только первые 255 символов - остальные удаляются. Читал, что возможно подобное ограничение. Как его устранить?

Добрый день! Работаю в 2003. При копировании в созданном листе в ячейке остаются только 255 символов - остальные удаляются. Что необходимо изменить в макросе, чтобы обойти данное ограничение при сохранении всех форматов (размеры полей и т.п.)?

Еще раз Добрый день! Сколько стоит заказ?

Добрый день? Есть ли возможность создать макрос, который бы записывал готовый файл Excell в другой файл в новый лист?

Добрый день, макрос супер. Только подскажите пожалуйста, как его заставить при сохранении брать данные имени файла из определенной ячейки напр. Лист1,А1?

Sub СохранитьЛистВФайл()
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

' копируем активный лист (при этом создаётся новая книга)
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

Все работает, спасибо!

Доброго времени суток, форумчане!
Подскажите, как поправить код, чтобы сохранялась одна и таже область (range("A1:G36")) со всех листов, подредактровал под себя код, всем заранее спасибо! Автору отдельно респект за макрос.

Sub savesheetsnewexcel()
Dim namefolder As String
Dim nameexcel As String
On Error Resume Next
 
namefolder = Sheets("Параметры").Cells(17, "A")
nameexcel = Sheets("Параметры").Cells(16, "A")
REPORTS_FOLDER = namefolder
 
MkDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
ChDrive Left(ThisWorkbook.Path, 1): ChDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
fileName = Application.GetSaveAsFilename(nameexcel, "Отчёты Excel (*.xls),", , _
                                             "", "Сохранить")
If VarType(fileName) = vbBoolean Then Exit Sub
Err.Clear: Worksheets(Array("пос2", "пос3", "пос10", "пос11", "пос12", "пос13", "пос15", "пос16", "пос17")).Copy: DoEvents
If Err Then Exit Sub
If ActiveWorkbook.Worksheets.Count = 9 And ActiveWorkbook.Path = "" Then
ActiveWorkbook.SaveAs fileName, xlWorkbookNormal
ActiveWorkbook.Close False
End If
End Sub

Добрый день! Поясните для тупого, что значит в модуле? И вы пишете - если в модуле листа, то будут сохраняться. Если в модуле, то нет

Спасибо, всё заработало!
Самый последний вопросик, пожалуйста!
Можно ли, чтобы в Новом созданном файле не было ни макроса, ни ссылок на него?
Кнопка, если она была на исходном Листе, может и остаться, но без привязанного макроса.
Навеки ваша поклонница... ))

Здравствуйте и спасибо за ваш чудо-макрос!
Что нужно в нем подправить, чтобы сохранение Нового файла с Новым Листом было
в формате .xlsx без поддержки макроса и чтобы модуль с макросом там удалился.
А то начинаются всякие вопросы о потери точности и т.п., что пугает пользователей...)

Доброго времени суток! Столкнулся с проблемой и по поиску выдало Ваш сайт. Очень надеюсь на вашу помощь.

Есть таблица, макрос производит некоторые манипуляции с таблицей и сохраняет файлы в папку. Необходимо чтобы в процессе создавалась папка с текущей датой (dd), а в ней уже создавались папки содержащие в своем названии переменную (usrnm). Макрос работал, до того момента, как добавилось создание папки в папке.

Dim usrnm As String
usrnm = Range("N6").Value
Dim dd As String
dd = Format(Now, "dd-mm-yyyy", vbUseSystemDayOfWeek)
Dim tdd As String
tdd = Format(Now, "dd-mm-yyyy (hh'mm'ss)")
Dim x As Boolean
x = Len(Dir("D:\________work\" & dd & "\" & usrnm, vbDirectory))
If usrnm = "" And Len(Dir("D:\________work\error\", vbDirectory)) = 0 Then
MkDir "D:\________work\error\"
ActiveWorkbook.SaveAs ("D:\________work\error\") & "Error_" & tdd, FileFormat:=51
End If
ActiveSheet.Range("$A$5:$AE$9999").AutoFilter Field:=14, Criteria1:=usrnm
If x = False Then
MkDir "D:\________work\" & dd & "\" & usrnm
ChDrive Left("D:\________work\", 1): ChDir "D:\________work\" & dd & "\" & usrnm
ActiveWorkbook.SaveAs bsnm & "_" & usrnm & "_" & tdd, FileFormat:=51
End If
If x = True Then
ChDrive Left("D:\________work\", 1): ChDir "D:\________work\" & dd & "\" & usrnm
ActiveWorkbook.SaveAs bsnm & "_" & usrnm & "_" & tdd, FileFormat:=51
End If

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

Sub Get_Value_From_Book2()
Dim sShName As String, sAddress As String, vData
Application.ScreenUpdating = False
Workbooks.Open "C:\*.xlsx"
sAddress = "A1:L26"
vData = Sheets("eNodeBOutdoor fin").Range(sAddress).Value
ActiveWorkbook.Close False
If IsArray(vData) Then
[A1].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
Else
[A1] = vData
End If
Application.ScreenUpdating = True
End Sub

Sub Сохранение()
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([e4] & ".xlsm", "Исполнительная (*.xlsm),", , _
"Введите имя файла для сохраняемого отчёта", "Сохранить")
' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
If VarType(Filename) = vbBoolean Then Exit Sub

' копируем активный лист (при этом создаётся новая книга)
Err.Clear: ActiveWorkbook.Copy: DoEvents
If Err Then Exit Sub ' произошла какая-то ошибка при попытке копирования листа

' убеждаемся, что активной книгой является копия листа
If ActiveWorkbook.Count = 1 And ActiveWorkbook.Path = "" Then
' сохраняем файл под заданным именем в формате Excel 2010
ActiveWorkbook.SaveAs Filename, xlOpenXMLWorkbookMacroEnabled

Я попробовал переписать тип xlsx на xlsm и внизу поставил сохранить как книгу с включенными макросами, но в итоге он пишет то, что постом ниже.
Прикладываю макрос который я попытался доработать. Я не спец в написании макросов, так для себя интересуюсь, для облегчения работы.

Пишет: "Следующие компоненты невозможно сохранить в книге без поддержки макросов:
-Проект VB
Чтобы сохранить файл со всеми компонентами, нажмите кнопку "нет", а затем в списке "Тип файла" выберите тип файла с поддержкой макросов"

после сохранения макросы не работают.

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