Excel макрос сохранить лист как отдельный файл - Word и Excel

Сохранение листов книги как отдельных файлов

Про сборку листов из нескольких книг в одну текущую я уже писал здесь. Теперь разберем решение обратной задачи: есть одна книга Excel, которую нужно «разобрать», т.е. сохранить каждый лист как отдельный файл для дальнейшего использования.

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

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

Способ 1. Простое разделение

Нажмите сочетание Alt+F11 или выберите в меню Сервис — Макрос — Редактор Visual Basic (Tools — Macro — Visual Basic Editor), вставьте новый модуль через меню Insert — Module и скопируйте туда текст этого макроса:

Sub SplitSheets1()
    Dim s As Worksheet
    For Each s In ActiveWorkbook.Worksheets    'проходим по всем листам в активной книге
        s.Copy       'копируем каждый лист в новый файл
    Next
End Sub

Если теперь выйти из редактора Visual Basic и вернуться в Excel, а затем запустить наш макрос (Alt+F8), то все листы из текущей книги будут разбиты по отдельным новым созданным книгам.

Способ 2. Разделение с сохранением

При необходимости, можно созданные книги сразу же сохранять под именами листов. Для этого макрос придется немного изменить, добавив команду сохранения в цикл:

Sub SplitSheets2()
    Dim s As Worksheet
    Dim wb as Workbook
    Set wb = ActiveWorkbook
    For Each s In wb.Worksheets                                 'проходим во всем листам активной книги
        s.Copy                                                  'сохраняем лист как новый файл
        ActiveWorkbook.SaveAs wb.Path & "" & s.Name & ".xlsx"  'сохраняем файл
    Next
End Sub

Этот макрос сохраняет новые книги-листы в ту же папку, где лежал исходный файл. При необходимости сохранения в другое место, замените wb.Path на свой путь в кавычках, например «D:Отчеты2012» и т.п.

Если нужно сохранять файлы не в стандартном формате книги Excel (xlsx), а в других (xls, xlsm, xlsb, txt и т.д.), то кроме очевидного изменения расширения на нужное, потребуется добавить еще и уточнение формата файла — параметр FileFormat:

ActiveWorkbook.SaveAs wb.Path & "" & s.Name & ".xlsb", FileFormat:=50

Для основных типов файлов значения параметра FileFormat следующие:

XLSX = 51
XLSM = 52
XLSB = 50
XLS = 56
TXT = 42

Полный список всех вариантов можно посмотреть в справке MSDN.

Способ 3. Сохранение в новые книги только выделенных листов

Если вы хотите раскидать по файлам не все листы в вашей книге, а только некоторые, то макрос придется немного изменить. Выделите нужные вам листы в книге, удерживая на клавиатуре клавишу Ctrl или Shift и запустите приведенный ниже макрос:

Sub SplitSheets3()
    Dim AW As Window
    Set AW = ActiveWindow
    For Each s In AW.SelectedSheets
        Set TempWindow = AW.NewWindow    'создаем отдельное временное окно
        s.Copy                           'копируем туда лист из выделенного диапазона
        TempWindow.Close                 'закрываем временное окно
    Next
End Sub

Создавать новое окно и копировать через него, а не напрямую, приходится потому, что Excel не умеет копировать группу листов, если среди них есть листы с умными таблицами. Копирование через новое окно позволяет такую проблему обойти.

Способ 4. Сохранение только выделенных листов в новый файл

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

Sub SplitSheets4()
    Dim CurW As Window
    Dim TempW As Window
    Set CurW = ActiveWindow
    Set TempW = ActiveWorkbook.NewWindow
    CurW.SelectedSheets.Copy
    TempW.Close
End Sub

Способ 5. Сохранение листов как отдельных PDF-файлов

Этот способ чем-то похож на второй, но листы сохраняются не как отдельные книги Excel, а в формате PDF, что часто требуется, если никто не должен менять документ и увидеть ваши формулы. Обратите внимание, что:

для этого используется уже другой метод (ExportAsFixedFormat а не Copy)
листы выводятся в PDF с параметрами печати, настроенными на вкладке Разметка страницы (Page Layout)
книга должна быть сохранена на момент экспорта

Нужный нам код будет выглядеть следующим образом:

Sub SplitSheets5()
    Dim s As Worksheet

    For Each s In ActiveWorkbook.Worksheets
        s.ExportAsFixedFormat Filename:=ThisWorkbook.Path & "" & s.Name & ".pdf", Type:=xlTypePDF
    Next
End Sub

Способ 6. Готовый макрос из надстройки PLEX

Если лень или нет времени внедрять все вышеописанное, то можно воспользоваться готовым макросом из моей надстройки PLEX:

Ссылки по теме

Сборка листов из нескольких книг в одну
Что такое макросы, куда вставлять код на Visual Basic, как их использовать.

Источник

0 / 0 / 0

Регистрация: 23.01.2012

Сообщений: 6

23.01.2012, 17:07. Показов 77793. Ответов 82

Процедура по нажатию кнопки-сохранить к примеру лист3 из текущей книги как отдельный файл.xls с названием текущей даты в отдельную папку. А также если файл с таким названием уже существует, тогда перезаписать! Подскажите пожалуйста! Заранее спасибо!

~~Апострофф~~

Заблокирован

23.01.2012, 21:55

Klim_ul, давай для начала с разделом определимся — это VB6 или VBA(Excel)?

Сообщение от Klim_ul

по нажатию кнопки-сохранить

Где такая кнопка есть — на форме, на листе, в тулбаре?

Сообщение от Klim_ul

как отдельный файл.xls с названием текущей даты в отдельную папку.

отдельную от чего? Конкретики маловато!

0 / 0 / 0

Регистрация: 23.01.2012

Сообщений: 6

24.01.2012, 10:10

[ТС]

Отдельно от самой книги… например открыта Книга.xls состоящая из 3-х листов, далее на каждом из листов ввели какую либо информацию…. Мне нужно сохранить только лишь Лист3 из этой книги, как отдельный файл.xls название которого будет текущая дата.

Добавлено через 2 минуты
Это VBA(Excel)! А кнопку создаем сами CommandButton и привязываем Макрос!

Добавлено через 40 секунд
Кнопка на листе!

Добавлено через 43 секунды
Апострофф, Буду оч. благодарен за помощь!

~~Апострофф~~

Заблокирован

24.01.2012, 11:23

Visual Basic

Option Explicit
 
Sub Макрос()
Dim p$, WB As Workbook
Dim i As Long
p = ThisWorkbook.Path
If VBA.Right$(p, 1) <> "" Then p = p & ""
p = p & Format(Date, "YYYYMMDD")
Set WB = Workbooks.Add
ThisWorkbook.Worksheets("Лист3").Copy After:=WB.Worksheets(WB.Worksheets.Count)
Application.DisplayAlerts = False
For i = 1 To WB.Worksheets.Count - 1
  WB.Worksheets(1).Delete
Next i
Application.DisplayAlerts = True
WB.SaveAs p
End Sub

KoGG

5590 / 1580 / 406

Регистрация: 23.12.2010

Сообщений: 2,366

Записей в блоге: 1

24.01.2012, 11:44

Процедура для активного листа. Кнопку расположишь сам, там где тебе нужно, и привяшешь к процедуре:

Visual Basic

Sub Сохранить_лист_в_отдельную_книгу()
    Prefix = "C:temp"
    Suffix = ".xls"
    NewFileName = Prefix & Format(Time, "hh-mm-ss") & Suffix
    ActiveSheet.Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=NewFileName _
        , FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWorkbook.Close SaveChanges:=False
    Application.DisplayAlerts = True
End Sub

Dragokas

17991 / 7617 / 890

Регистрация: 25.12.2011

Сообщений: 11,351

Записей в блоге: 17

24.01.2012, 11:45

Сообщение было отмечено как решение

Решение

Visual Basic

Private Sub CommandButton1_Click()
Dim FileN$
FileN = ThisWorkbook.Path & "" & Date & ".xls"
ThisWorkbook.Sheets(3).Copy
ActiveWorkbook.SaveCopyAs FileN
ActiveWorkbook.Close SaveChanges:=False
MsgBox "Лист № 3 сохранен в новой книге " & FileN
End Sub

Вложения

SaveAS.xls (28.5 Кб, 847 просмотров)

0 / 0 / 0

Регистрация: 23.01.2012

Сообщений: 6

25.01.2012, 11:51

[ТС]

Огромное Всем спасибо!!!

Добавлено через 15 минут
И еще один вопрос… Где указать путь куда будет сохраняться файл. В данных примерах у меня сохраняет в текущую директорию, а мне нужно указать другой путь!

17991 / 7617 / 890

Регистрация: 25.12.2011

Сообщений: 11,351

Записей в блоге: 17

25.01.2012, 17:35

Апострофф, p = ThisWorkbook.Path
Diskretor, FileN = ThisWorkbook.Path & «» & Date & «.xls»
ThisWorkbook.Path меняете на, например, «C:temp»
KoGG, Prefix = «C:temp»

0 / 0 / 0

Регистрация: 23.01.2012

Сообщений: 6

25.01.2012, 20:37

[ТС]

Diskretor, Огромное спасибо и тысяча извинений, потому что у меня еще один вопрос… Теперь как сделать чтобы сохранение производилось в той папке где находится книга но в отдельную папку так чтобы это не влияло на первоначальный путь….. Простите я сам не понял что написал……
Ладно покажу так. Например
Сечас у меня сохраняет «D:ДокументыОтчеты» Все отлично, но если поменять имя папки «Документы» на «База» то нужно заходить опять в код программы и менять путь. Вопрос как этого избежать. Сама книга находится в той же папке где папка для сохранения «Отчеты»

~~Апострофф~~

Заблокирован

25.01.2012, 21:42

Сообщение было отмечено как решение

Решение

Visual Basic

1	FileN = ThisWorkbook.Path & "Отчеты" & Date & ".xls"

Это поправка в код Diskretor`а на

Сообщение от Klim_ul

Вопрос как этого избежать.

Не по теме:

Плохо, когда ноги с головой не дружат:D

ThisWorkbook.Sheets(3).Copy

Даже не догадывался, что подобная команда соэдает новую книгу с указанным листомО_о

Dragokas

17991 / 7617 / 890

Регистрация: 25.12.2011

Сообщений: 11,351

Записей в блоге: 17

25.01.2012, 23:56

Сообщение было отмечено как решение

Решение

Апострофф, я Вам даже скажу больше:
если туда подставить строковой массив, в котором будут имена листов этой книги, то будет создана новая книга с копиями этих листов.
Т.е. код ниже создает копию этой книги со всеми листами, кроме последнего:

Visual Basic

Option Explicit
Option Base 1
Sub aa()
Dim arSheets$(), a%
ReDim arSheets(Sheets.Count - 1)
For a = 1 To Sheets.Count - 1
    arSheets(a) = ThisWorkbook.Sheets.Item(a).Name
Next
ThisWorkbook.Sheets(arSheets).Copy
End Sub

P.S. ради интереса проверил. Можно подставлять и Integer массив с номерами листов. Эффект будет такой же:

Visual Basic

Option Explicit
Option Base 1
Sub aa()
Dim arSheets%(), a%
ReDim arSheets(Sheets.Count - 1)
For a = 1 To Sheets.Count - 1
    arSheets(a) = a
Next
ThisWorkbook.Sheets(arSheets).Copy
End Sub

DanAttess

0 / 0 / 0

Регистрация: 29.05.2012

Сообщений: 3

29.05.2012, 10:55

А как можно скопировать 2 вполне определенных листа.
Будет ли работать:

Visual Basic

1
2
3

ThisWorkbook.Sheets(2).Copy
ThisWorkbook.Sheets(3).Copy
ActiveWorkbook.SaveCopyAs FileN

~~Апострофф~~

Заблокирован

29.05.2012, 13:02

Visual Basic

1 2	ThisWorkbook.Sheets(Array(2, 3)).Copy ActiveWorkbook.SaveCopyAs FileN

DanAttess, а почитать, что Diskretor постом выше написал не судьба?
Ваш код создаст две новые книги с одним листом в каждой, причём сохранит только последнюю!

DanAttess

0 / 0 / 0

Регистрация: 29.05.2012

Сообщений: 3

29.05.2012, 18:05

Спасибо! Это мой первый опыт в VBA. Не судите строго!
Не подскажите, сложно ли сделать так, чтобы все выражения в скопированных листах были сохранены как значения?

Добавлено через 49 минут
В коде ниже сохранять как значение, если использовать массивы не получается:

Visual Basic

1
2
3

With Sheets("sheet1").UsedRange
.Value = .Value
End With

~~Апострофф~~

Заблокирован

29.05.2012, 18:29

Сообщение от DanAttess

если использовать массивы не получается

Не опускаем руки, делаем с массивами

Visual Basic

Dim ws As Worksheet
ThisWorkbook.Sheets(Array(2, 3)).Copy
For Each ws In ActiveWorkbook.Worksheets
  With ws.UsedRange
    .Value = .Value
  End With
Next ws

0 / 0 / 0

Регистрация: 23.07.2012

Сообщений: 7

23.07.2012, 13:38

Здравствуйте. В экселе не шибко силен. Кто-нибудь может выложить файл с таким примером: чтобы при нажатии кнопки «сохранить» сохранялся допустим лист 2 (на котором будет таблица с формулами), но чтобы сохранялся лист не с формулами, а со значениями, стиль шрифта, размеры столбцов, границы таблицы желательно оставить неизменными. При этом чтобы можно было выбирать путь сохранения и имя файла (или второй вариант — фиксированный путь сохранения и имя файла, допустим сделать 2 кнопки с разными способами сохранения). Честно пытался разобраться с представленными здесь способами, но знаний маловато. Думаю по примеру было бы проще сообразить что к чему

1121 / 229 / 36

Регистрация: 15.03.2010

Сообщений: 698

23.07.2012, 15:13

Здравствуйте. В экселе не шибко силен. Кто-нибудь может выложить файл с таким примером: чтобы при нажатии кнопки «сохранить» сохранялся допустим лист 2 …

Когда то очень давно писал что то похожее. Макрос копирует выделенные листы в новую книгу и удаляет все, что выходит за пределы печати. Также удаляет все скрытые строки и столбцы в страницах печати. Есть одна неприятность, если удаляемая ячейка объедененная, то теряется ее значение.

0 / 0 / 0

Регистрация: 23.07.2012

Сообщений: 7

24.07.2012, 07:55

Вот это почти похоже на правду. То что удаляет все за областью печати — это не страшно. При сохранении можно указать путь и имя, и что сохраняет значения, а не формулы — это все то что надо. Только как бы немного доработать, чтобы сохранялся не выделенный лист, а к примеру так: на первом листе будут какие-то расчеты и кнопка сохранить, а таблицы с результатами на втором и третьем листе. И вот при нажатии на кнопку сохранить, сохранялись бы второй и третий листы в отдельной книге.

Добавлено через 2 часа 30 минут
DanAttess, А можно увидеть файл с результатом сохранений?

Dragokas

17991 / 7617 / 890

Регистрация: 25.12.2011

Сообщений: 11,351

Записей в блоге: 17

24.07.2012, 14:56

Visual Basic

Sub Into_New_Book()
Dim Ar(), ArAll&(), Sh As Excel.Worksheet, n
Ar = Array(2, 3) 'порядковые номера сохраняемых листов с формулами
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
ActiveWorkbook.Sheets(Ar(0)).Activate
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
  End If
Next
Application.DisplayAlerts = False
  ActiveWorkbook.Worksheets(ArAll).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Dialogs(xlDialogSaveAs).Show
End Sub

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

0 / 0 / 0

Регистрация: 23.07.2012

Сообщений: 7

24.07.2012, 15:58

Превосходно! Спасибо большое. Подскажите еще пожалуйста, что надо изменить, если этих листов листов не 2 а 20? И другой вопрос сразу: можно сделать так чтобы из этих 20 листов сохранялись не все, а выборочные — в зависимости от условий. К примеру если ячейка А1=0, то сохраняются листы 2-15, если А1=1, то листы 2-18, если А1=2, то лист 19, если А1=3, то листы 2-20. Понятно что слишком замудрено, но такое возможно или вообще никак?

Источник

Создание файлов
Листы 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 что-то там перемудрил)

178124 просмотра

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

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

Источник

Сохранить лист в отдельный файл.

Wasilich

Дата: Понедельник, 28.10.2013, 22:20 |
Сообщение № 1

Группа: Друзья

Ранг: Старожил

Сообщений: 1232

Репутация:
326
±

Замечаний:
0% ±

2003

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

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

К сообщению приложен файл:

7023102.xls
(49.5 Kb)

Ответить

AndreTM

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

Группа: Друзья

Ранг: Старожил

Сообщений: 1762

Репутация:
498
±

Замечаний:
0% ±

2003 & 2010

Я, вроде бы, там и там как раз и говорил про это.
А корректировка… Ну, откорректируйте:
— .InitialFileName = iPath в вашем варианте излишен. И, мне кажется, что при одиночном сохранении — подстановка имени файла в диалог более логична
— .DisplayAlerts — желательно отключать/включать тогда, когда необходимо подавить сообщения, а не на всё время процедуры
— Sheets(Sh.Name). <=> Sh. (не забывайте — Sheets() относится к ActiveWorkbook., так что использование коллекции без указания родителя — чревато)
— Попробуйте избавиться от использования ActiveWorkbook.
— Процедура массового сохранения может быть с параметром, как раз и определяющим этот ваш «конкретный» лист (или устанавливающий его на ActiveSheet)
— Процедуру сохранения одного листа можно заменить на функцию с параметрами, возврат — сохраненное имя; и тогда её можно будет использовать в процедуре массового сохранения, которая будет заключаться только в переборе нужных листов
— «Очистку» листа копии тоже можно сделать параметрической — ввести ещё один параметр функции, который будет определять, что именно нужно очистить на листе
— И плиз, не надо месседжбоксов! А если очень надо — то просто вызовы процедур оборачиваются в дополнительный интерактив. Ведь ваше сообщение неинформативно — вы же правильность копирования нигде не проверяете.

Skype: andre.tm.007
Donate: Qiwi: 9517375010

Сообщение отредактировал AndreTM — Вторник, 29.10.2013, 02:50

Ответить

RAN

Дата: Вторник, 29.10.2013, 04:19 |
Сообщение № 3

Группа: Друзья

Ранг: Экселист

Сообщений: 5645

Попробуйте избавиться от использования ActiveWorkbook

А чем не нравится ActiveWorkbook, и как еще можно идентифицировать новую книгу до ее сохранения?

Быть или не быть, вот в чем загвоздка!

Ответить

AndreTM

Дата: Вторник, 29.10.2013, 04:44 |
Сообщение № 4

Группа: Друзья

Ранг: Старожил

Сообщений: 1762

Репутация:
498
±

Замечаний:
0% ±

2003 & 2010

В этом методе (когда копируется один лист через .Copy без параметров) — никак. Впрочем, я же показывал: сразу после копирования — назначаем ActiveWorkbook объектной переменной. И дальше работаем исключительно с ней.
В других же случаях — методы возвращают ссылку на книгу, например:
[vba]

Код

Set NewWB = Workbooks.Add

[/vba]

Skype: andre.tm.007
Donate: Qiwi: 9517375010

Ответить

Wasilich

Дата: Вторник, 29.10.2013, 12:53 |
Сообщение № 5

Группа: Друзья

Ранг: Старожил

Сообщений: 1232

Репутация:
326
±

Замечаний:
0% ±

2003

А корректировка… Ну, откорректируйте:

Андрей, я не себя имел ввиду. Ибо данный пример сделан на моем уровне познания VBA.
И пример по теме может быть не только мой. Так что, предлагайте свои варианты.

Ответить

RAN

Дата: Вторник, 29.10.2013, 22:27 |
Сообщение № 6

Группа: Друзья

Ранг: Экселист

Сообщений: 5645

Wasilic, вариант для 1 листа
[vba]

Код

Private Sub Save_as()
10  With Application.FileDialog(msoFileDialogSaveAs)
20      .InitialFileName = ThisWorkbook.Path & «» & «Сравнение»
30      If .Show = 0 Then Exit Sub
40      ThisWorkbook.ActiveSheet.Copy
50      Application.DisplayAlerts = False
60      .Execute
70      Application.DisplayAlerts = True
80  End With
90  ActiveWorkbook.Close False
End Sub

[/vba]

Быть или не быть, вот в чем загвоздка!

Ответить

Wasilich

Дата: Вторник, 29.10.2013, 23:40 |
Сообщение № 7

Группа: Друзья

Ранг: Старожил

Сообщений: 1232

Репутация:
326
±

Замечаний:
0% ±

2003

Wasilic, вариант для 1 листа

Спасибо Андрей. Только Ник мой убери, это ж не для меня, и цифорки из кода тоже, иначе будут вопросы — «а зачем цифры?»!

Вот еще варианты в примере, в т.ч. с макросом от AndreTM если он не возражает.

К сообщению приложен файл:

___2.xls
(45.0 Kb)

Ответить

RAN

Дата: Среда, 30.10.2013, 00:23 |
Сообщение № 8

Группа: Друзья

Ранг: Экселист

Сообщений: 5645

Любой каприз ….

Вариант для 1 листа
[vba]

Код

Private Sub Save_as()
    With Application.FileDialog(msoFileDialogSaveAs)
        .InitialFileName = ThisWorkbook.Path & «» & «Сравнение»
        If .Show = 0 Then Exit Sub
        ThisWorkbook.ActiveSheet.Copy
        Application.DisplayAlerts = False
        .Execute
        Application.DisplayAlerts = True
    End With
    ActiveWorkbook.Close False
End Sub

[/vba]

Быть или не быть, вот в чем загвоздка!

Сообщение отредактировал RAN — Среда, 30.10.2013, 00:25

Ответить

RAN

Дата: Среда, 30.10.2013, 00:33 |
Сообщение № 9

Группа: Друзья

Ранг: Экселист

Сообщений: 5645

Wasilic, лучше выкладывай коды, а не файлы.
Файл качать надо, а по коду сразу может быть понятно — не то.
Файлы — бонус.

Быть или не быть, вот в чем загвоздка!

Ответить

Wasilich

Дата: Среда, 30.10.2013, 01:33 |
Сообщение № 10

Группа: Друзья

Ранг: Старожил

Сообщений: 1232

Репутация:
326
±

Замечаний:
0% ±

2003

Файл качать надо, а по коду сразу может быть понятно — не то.

Это нам с тобой просто, посмотрел и понятно. А тем кто знает, что «никто не знает» — сложновато будет. А, в фале оно уже как бы и работает. ИМХО.

Ответить

AndreTM

Дата: Среда, 30.10.2013, 02:47 |
Сообщение № 11

Группа: Друзья

Ранг: Старожил

Сообщений: 1762

Репутация:
498
±

Замечаний:
0% ±

2003 & 2010

от AndreTM если он не возражает

Нэ вазражайу (с)

К сообщению приложен файл:

0748227.jpg
(11.4 Kb)

Skype: andre.tm.007
Donate: Qiwi: 9517375010

Ответить

DAKRAY

Дата: Четверг, 09.01.2014, 18:19 |
Сообщение № 12

Группа: Пользователи

Ранг: Участник

Сообщений: 73

Репутация:
1
±

Замечаний:
0% ±

Excel 2003

Всем добрый.

В приложении еще один простенький вариант сохранения.
Изначальный код мне скинул antal10, переделал под свои нужды.

[vba]

Код

Private Sub SaveSheets_Click()
Dim Fname As String
     Application.ScreenUpdating = False
     Fname = ThisWorkbook.Path & «» & Sheets(«Sheet1»).Range(«A1″).Value & » » & Range(«B1»).Text & «.xls» ‘тут название файла состоит из названия фирмы и нр. счета
     Sheets(Array(«Sheet1», «Sheet2»)).Copy ‘указываем листы, которые хотим оставить
     Sheets(«Sheet1»).Shapes(«SaveSheets»).Delete ‘удаляем ненужные кнопки (в моем случае у меня есть кнопки, которые должны остаться)
     With ActiveWorkbook
          Application.DisplayAlerts = False
          .SaveAs Filename:=Fname
          Application.ScreenUpdating = True
          Application.DisplayAlerts = True
          ‘.Close
     End With
     Workbooks(«Book_Save.xls»).Close 0
End Sub

[/vba]

П.С. Только вот никак не получается сделать так, чтобы модуль (функция) тоже копировался в новую книгу. Там у меня сумма прописью. Можно в принципе и значение только копировать, не обязательно с модулем — как проще. Если не сложно help подскажите!)

Ответить

shebelme

Дата: Понедельник, 06.10.2014, 08:05 |
Сообщение № 13

Группа: Пользователи

Ранг: Прохожий

Сообщений: 2

Репутация:
0
±

Замечаний:
0% ±

Excel 2007

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

Ответить

Wasilich

Дата: Среда, 08.10.2014, 00:21 |
Сообщение № 14

Группа: Друзья

Ранг: Старожил

Сообщений: 1232

Репутация:
326
±

Замечаний:
0% ±

2003

изменить код таким образом, что бы был прописан конкретный адрес

Так попробуйте.
[vba]

Код

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

[/vba]

Ответить

Ферхо

Дата: Воскресенье, 07.12.2014, 14:28 |
Сообщение № 15

Группа: Пользователи

Ранг: Новичок

Сообщений: 10

Репутация:
1
±

Замечаний:
0% ±

Excel 2010

Не претендую ни на что, просто я делаю так (возможно кому-то пригодится идея)

[vba]

Код

‘сохранить лист в отдельном файле
‘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

fnSheetsSave = False

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

Application.ScreenUpdating = False

           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

fnSheetsSave = True

lEXITfnSheetsSave:

Application.ScreenUpdating = True

TRC.Push

End Function

[/vba]

Если очень хочется, то можно!

2B|`2B?

Ответить

kbcgv

Дата: Суббота, 10.01.2015, 15:54 |
Сообщение № 16

Группа: Пользователи

Ранг: Прохожий

Сообщений: 2

Репутация:
0
±

Замечаний:
20% ±

Excel 2010

Wasilic, вариант для 1 листа

Private Sub Save_as()
10 With Application.FileDialog(msoFileDialogSaveAs)
20 .InitialFileName = ThisWorkbook.Path & «» & «Сравнение»
30 If .Show = 0 Then Exit Sub
40 ThisWorkbook.ActiveSheet.Copy
50 Application.DisplayAlerts = False
60 .Execute
70 Application.DisplayAlerts = True
80 End With
90 ActiveWorkbook.Close False
End Sub

Пригодился идеально ваш код. Спасибо.

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

В нём имя изменил, для того чтобы формировал имя из ячеек на листе.

[vba]

Код

Sub Save_as()
10 With Application.FileDialog(msoFileDialogSaveAs)
20 .InitialFileName = [b3] & » » & [b8]
30 If .Show = 0 Then Exit Sub
40 ThisWorkbook.ActiveSheet.Copy
50 Application.DisplayAlerts = False
60 .Execute
70 Application.DisplayAlerts = True
80 End With
90 ActiveWorkbook.Close False
End Sub

[/vba]

[moder]Оформляйте коды тегами
Кнопка #[/moder]

Сообщение отредактировал DJ_Marker_MC — Суббота, 10.01.2015, 16:28

Ответить

RAN

Дата: Суббота, 10.01.2015, 16:44 |
Сообщение № 17

Группа: Друзья

Ранг: Экселист

Сообщений: 5645

формировал имя из ячеек на листе.

В отличие от макроса из #15, этот макрос не может в принципе.
Для того, чтобы работал из надстройки, нужно так
[vba]

Код

40 ActiveWorkbook.ActiveSheet.Copy

[/vba]

Быть или не быть, вот в чем загвоздка!

Ответить

kbcgv

Дата: Суббота, 10.01.2015, 17:32 |
Сообщение № 18

Группа: Пользователи

Ранг: Прохожий

Сообщений: 2

Репутация:
0
±

Замечаний:
20% ±

Excel 2010

В отличие от макроса из #15, этот макрос не может в принципе.

Не может делать имя из ячеек?
Я в этом ничего практически не понимаю, методом тыка всё. Именно из ячееек b3 и b8 и делает имя.

И всё как хотелось работает в виде надстройки, благодаря:

Для того, чтобы работал из надстройки, нужно так

40 ActiveWorkbook.ActiveSheet.Copy

Спасибо.

Ответить

AVI

Дата: Среда, 07.09.2016, 05:36 |
Сообщение № 19

Группа: Проверенные

Ранг: Ветеран

Сообщений: 523

Репутация:
17
±

Замечаний:
0% ±

Excel 2016

Добрый день!
Как сделать так, что бы при сохранении файла удалялись 5 первых столбцов?
И как при сохранении можно самостоятельно называть файл?

Сообщение отредактировал AVI — Среда, 07.09.2016, 05:39

Ответить

китин

Дата: Среда, 07.09.2016, 07:20 |
Сообщение № 20

Группа: Модераторы

Ранг: Экселист

Сообщений: 6973

Репутация:
1063
±

Замечаний:
0% ±

Excel 2007;2010;2016

правила прочитать и задать вопрос в соответствующей теме

Не судите очень строго:я пытаюсь научиться
ЯД 41001877306852

Ответить

Источник

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

Приблизительно так

Sub SaveSheet()


Dim ActiveSht As Worksheet
Dim NewWb As Workbook
    Set ActiveSht = ActiveSheet
    Set NewWb = Workbooks.Add
    ActiveSht.Copy Before:=Workbooks(NewWb.Name).Sheets(1)
    With ActiveSheet.UsedRange
        .Value = .Value
    End With
    ActiveWorkbook.SaveAs Filename:="C:" & ActiveSht.Name
    MsgBox "Лист скопирован в новую книгу и сохранён!", , ""
End Sub

Разрабатываю макросы под заказ.
Email: MacrosForYou собака yandex точка ru

Павел, а возможно в данном макросе привязать имя файла к определенной ячейке листа?
ЗЫ: прошу не пинать, возможно подобный вопрос уже был, но поскольку полный профан в ВБА, поиск не поможет((

Цитата: Jammer от 19.12.2008, 11:15
Возможно в данном макросе привязать имя файла к определенной ячейке листа?

Элементарно поменяйте имя листа (ActiveSht.Name) на адрес ячейки:

ActiveWorkbook.SaveAs Filename:="C:" & [A1]

Знания недостаточно, необходимо применение. Желания недостаточно, необходимо действие. (с) Брюс Ли

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

Заменить:
ActiveSht.Copy Before:=Workbooks(NewWb.Name).Sheets(1)

На
ActiveSht.Copy Before:=ActiveWorkbook.Sheets(1)

и часть нижнего кода уже не нужна

ActiveWorkbook.SaveAs Filename:=»C:» & ActiveSht.Name
MsgBox «Лист скопирован в новую книгу и сохранён!», , «»

Благодарю за ответ,ток я cделал ошибку — не приложил фаил. Можно ещё разок,на моём примере. Лист «1» продублировать в книге с изменением его имени на имя из ячейки E2 допустим, дублирование осуществляется при нажатии на кнопку «нажать» на листе «1».Как это реализовать через макрос?

Цитата: Шпец Докапыч от 20.12.2008, 14:49

Цитата: Jammer от 19.12.2008, 11:15
Возможно в данном макросе привязать имя файла к определенной ячейке листа?

Элементарно поменяйте имя листа (ActiveSht.Name) на адрес ячейки:
ActiveWorkbook.SaveAs Filename:="C:" & [A1]

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

ActiveWorkbook.SaveAs Filename:=»C:» & [A1] & «_» & now()

Не торопись, и все успеешь намного быстрее

Замените Now() на Date & «.xls»
или другое расширение (xlsm, xlsb, …)
в Now() время записано через двоеточие — низззя

Скажи мне, кудесник, любимец ба’гов…

Яндекс-деньги: 41001632713405
Webmoney: R289877159277; Z102172301748; E177867141995

спасибо Борода, теперь буду знать, как в макросе текущая дата прописывается

Не торопись, и все успеешь намного быстрее

Цитата: _Boroda_ от 27.08.2010, 15:36
Замените Now() на Date & «.xls»
или другое расширение (xlsm, xlsb, …)
в Now() время записано через двоеточие — низззя

спасибо большое, только в имени файла не отображается значение из ячейки [BE3], и как можно прописать диапазон ячеек

Цитата: _Boroda_ от 27.08.2010, 16:03
У меня работает
ActiveWorkbook.SaveAs Filename:="C:Documents and SettingsМои документыСтереть" & [c5] & "_" & Date & ".xls"

Что значит

Цитироватькак можно прописать диапазон ячеек

диапазону ячеек присвоила имя и его прописала
ActiveWorkbook.Names(«f12p3s1») чтобы в имени нового файла отображалось значение, все получилось

выдает ошибку
application-defined or object-defined error

не могу понять что изменить, помогите пожалуйста

Sub CommandButton11_Click()

Sheets(«Ф11(п)»).Select

Dim ActiveSht As Worksheet
Dim NewWb As Workbook

Set ActiveSht = ActiveSheet
Set NewWb = Workbooks.Add
ActiveSht.Copy Before:=Workbooks(NewWb.Name).Sheets(1)
With ActiveSheet.UsedRange
.Value = .Value
End With

ActiveWorkbook.SaveAs Filename:=»C:KartochkiФормыФ11ф11 » & ActiveSht.Name & Year(Date) & «.» & Month(Date) & «.» & Day(Date) & «_» & ActiveWorkbook.Names(«f11p3s2»).RefersToRange.Value & «.xls»

MsgBox «Лист скопирован в новую книгу и сохранён!», , «»

ActiveWorkbook.Close

Sheets(«Ф11»).Select

ActiveWorkbook.Close savechanges:=False

End Sub

мне необходимо скопировать лист книги и сохранить его в новой книге, в имени которой должно отображаться имя листа, текущая дата и ActiveWorkbook.Names(«f11p3s2»), т.е. значение ячейки, которой присвоено имя
дело в том, что данный макрос прописанный в трех листах (с другими именами ф12,ф3 и ф1) замечательно работает, а трех листах ф11,ф2 и ф4 выдает вот такую ошибку, хотя его копирую один в один, меняя лишь наименование листа и имя ячейки

Цитата: _Boroda_ от 15.09.2010, 15:48
Не очень понял, что должно делать
ActiveWorkbook.Names(«f11p3s2»).RefersToRange.Value

что это должно делать мне сложно сказать, мне подсказали на форуме так написать и оно сработало, извините за неграмотность

Источник