mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

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

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

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

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

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

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

 

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

Но, как ни странно, выполнение кода ActiveSheet.SaveAs "<имя файла>" приводит к сохранению книги целиком, что равносильно использованию кода ActiveWorkbook.SaveAs "<имя файла>"

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

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

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

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

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

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

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

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

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

Сохраняю листы в 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

замените эту строку следующим:
REPORTS_FOLDER = Cheets("InvKart").cells(13,6)

Доброго времени суток!
Подскажи пожалуйста как указать имя создаваемой папки с ячейки например(Лист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 символов - остальные удаляются. Что необходимо изменить в макросе, чтобы обойти данное ограничение при сохранении всех форматов (размеры полей и т.п.)?

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

Здравствуйте, Rusmay.
Да, конечно. Под заказ можно сделать что угодно.

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

Чтобы сохранить файл с именем из ячейки,
замените строки

' вывод диалогового окна для запроса имени сохраняемого файла
Filename = Application.GetSaveAsFilename("отчёт.xls", "Отчёты Excel (*.xls),", , _
"Введите имя файла для сохраняемого отчёта", "Сохранить")
' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
If VarType(Filename) = vbBoolean Then Exit Sub

на строку типа
Filename = "c:\моя папка\" & range("a1") & ".xls"

Добрый день, макрос супер. Только подскажите пожалуйста, как его заставить при сохранении брать данные имени файла из определенной ячейки напр. Лист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

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

Александр, тут, вообще-то, не форум...

Попробуйте так:

    If ActiveWorkbook.Worksheets.Count = 9 And ActiveWorkbook.Path = "" Then
        ' перебираем все листы, удаляя лишнее
        Dim sh As Worksheet
        For Each sh In ActiveWorkbook.Worksheets
            sh.Range("H:IV").EntireColumn.Clear
            sh.Range("37:" & sh.Rows.Count).EntireRow.Clear
        Next
        ' и потом уже сохраняем
        ActiveWorkbook.SaveAs Filename, xlWorkbookNormal
        ActiveWorkbook.Close False
    End If

Доброго времени суток, форумчане!
Подскажите, как поправить код, чтобы сохранялась одна и таже область (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, — после закрытия и повторного открытия созданного файла, в нём не будет никаких макросов.
Кнопку можно тоже удалить одной строкой кода, — например, так:

ActiveSheet.shapes(1).delete

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

Здравствуйте, Катерина

замените в коде

' сохраняем файл под заданным именем в формате Excel 2003
ActiveWorkbook.SaveAs Filename, xlWorkbookNormal

на

' сохраняем файл под заданным именем в формате XLSX
Application.DisplayAlerts=False ' отключаем вывод предупреждения о потере точности
ActiveWorkbook.SaveAs Filename, xlOpenXMLWorkbook ' xlOpenXMLWorkbook = формат XLSX
Application.DisplayAlerts=True ' обратно включаем вывод предупреждений

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

Константин, так попробуйте:

Sub test()
    On Error Resume Next        ' эта строка обязательна
    Dim usrnm As String, dd As String, tdd As String
    usrnm = Range("N6").Value
 
    dd = Format(Now, "dd-mm-yyyy")
    tdd = Format(Now, "dd-mm-yyyy (hh'mm'ss)")
 
    If usrnm = "" Then
        MkDir "D:\________work\error\"
        ActiveWorkbook.SaveAs "D:\________work\error\" & "Error_" & tdd, FileFormat:=51
    Else
        ActiveSheet.Range("$A$5:$AE$9999").AutoFilter Field:=14, Criteria1:=usrnm
 
        MkDir "D:\________work\" & dd & "\"        ' сначала создается папка с текущей датой
        MkDir "D:\________work\" & dd & "\" & usrnm & "\"        ' и только потом - подпапка с именем пользователя

        If Dir("D:\________work\" & dd & "\" & usrnm & "\", vbDirectory) <> "" Then
            ActiveWorkbook.SaveAs "D:\________work\" & dd & "\" & usrnm & "\" & bsnm & "_" & usrnm & "_" & tdd, FileFormat:=51
        End If
    End If
End Sub

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

Есть таблица, макрос производит некоторые манипуляции с таблицей и сохраняет файлы в папку. Необходимо чтобы в процессе создавалась папка с текущей датой (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

Здравствуйте, Кайрат.
Это совсем другой макрос нужен (макрос, описанный в статье, делает совсем другое)
Ваш макрос тоже надо переделывать, — много файлов одной строкой кода типа Workbooks.Open "C:\*.xlsx" никак не открыть
(нужен цикл по файлам)
Можем сделать макрос под заказ. Или обратитесь на форумы по Excel, если хотите бесплатно.

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

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
Чтобы сохранить файл со всеми компонентами, нажмите кнопку "нет", а затем в списке "Тип файла" выберите тип файла с поддержкой макросов"

Если ваши макросы в модуле листа - то они скопируются вместе с листом, и будут работать.
Если же макросы в модуле - то, конечно, при сохранении листа в файл эти модули не будут перенесены в новый файл

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

А разве формат xls, заданный в коде, не поддерживает макросы?

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

Добрый день. Прошу помощи в примитивной наверное для вас ошибки... Сам дуб дубом пока что в VBA, надеюсь со временем обучусь.
Проблема в том, что есть чекбоксы в виде галочек, для них есть кнопки (выделить все и снять выделение),есть формулы в ячейках. И чтобы случайно их не удалили, поставил защиту. Часть ячеек без защиты (нужны для ввода данных). Так вот проблема в том, что после сохранения перестают отробатывать макросы для этих самых голочек, при нажатии кнопок под них. ошибка в строкt:
Range("B5:G5, K5:O5").Interior.Color = RGB(196, 215, 155)

такой написан код: (для голочки с выделением по цвету и двух кнопок)
Private Sub CheckBox1_Click()
If CheckBox1 = True Then
Range("B5:G5, K5:O5").Interior.Color = RGB(196, 215, 155)
Else
Range("B5:G5, K5:O5").Interior.Color = RGB(196, 215, 155)
End If
End Sub
Private Sub CommandButton1_Click()
CheckBox1 = 1
End Sub
Private Sub CommandButton2_Click()
CheckBox1 = 0
End Sub

Такой код написан для защиты листа
Sub Protect_for_User_Non_for_VBA()
Sheets(Лист1).Protect Password:="", UserInterfaceOnly:=True
End Sub

тогда макрос будет выглядеть так:

Sub СохранитьЛистыВФайл()
    Application.ScreenUpdating = False
    arr = Array("Техн.тепло", "Вода", "Стоки", "отопление", "Эл .энергия", "Вода хоз.быт.", "Хозбытовые стоки", "воздух")
 
    For i = LBound(arr) To UBound(arr): Worksheets(arr(i)).Visible = True: Next i        ' отображаем листы
    Err.Clear: Worksheets(arr).Copy: DoEvents        ' копируем листы

    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\отчёт.xls", xlWorkbookNormal
    ActiveWorkbook.Close False
 
    For i = LBound(arr) To UBound(arr): Worksheets(arr(i)).Visible = xlSheetVeryHidden: Next i        ' скрываем листы
    Application.ScreenUpdating = True
End Sub

Спасибо за ответ. все дело было в неверном указании количества листов. А переменная ПутьКПапке выбирается пользователем ранее. Правда теперь у меня встал следующий вопрос. Крайне не хочется позволять пользователю менять какие либо значения в исходном файле, для чего собственно и копируется часть листов в отдельный файл. А так как у меня параноя прокачена в 10 я поставил всем листам книги свойство very hidden. Есть ли возможность как-нибудь изменить код, что бы можно было производить операцию копирования листов с этим свойством?

Тимон, в моём коде проверяется, чтобы в копии файла был один лист:

If ActiveWorkbook.Worksheets.Count = 1

А у вас в копии файла - несколько листов

исправьте 1 на 8, - и всё заработает

и ещё, - вы где-то потеряли строку, которая записывает в переменную ПутьКПапке собственно этот самый путь

в итоге, получится так:

Sub СохранитьЛистыВФайл()
    On Error Resume Next
    Filename = "отчёт.xls"
 
    ' копируем активный лист (при этом создаётся новая книга)
    Err.Clear: Worksheets(Array("Техн.тепло", "Вода", "Стоки", "отопление", "Эл .энергия", "Вода хоз.быт.", "Хозбытовые стоки", "воздух")).Copy: DoEvents
    If Err Then Exit Sub        ' произошла какая-то ошибка при попытке копирования листа

    If ActiveWorkbook.Worksheets.Count = 8 And ActiveWorkbook.Path = "" Then
        ' сохраняем файл под заданным именем в формате Excel 2003
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Filename, xlWorkbookNormal
        ' закрываем сохранённый файл
        ActiveWorkbook.Close False
    End If
End Sub

Написал код по образцу:

Sub СохранитьЛистыВФайл()
Filename = "отчёт.xls"

' копируем активный лист (при этом создаётся новая книга)
Err.Clear: Worksheets(Array("Техн.тепло", "Вода", "Стоки", "отопление", "Эл .энергия", "Вода хоз.быт.", "Хозбытовые стоки", "воздух")).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

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

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

У меня оффис 2010. При сохранении нарушается ширина столбцов. Как исправить???

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
   ___    _  __ __        __          _____  _____
/ _ \ | |/ / \ \ / / __ _ |__ / |__ /
| (_) | | ' / \ \ /\ / / / _` | / / / /
\__, | | . \ \ V V / | (_| | / /_ / /_
/_/ |_|\_\ \_/\_/ \__, | /____| /____|
|_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

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