Vba 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, как их использовать.

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

Сохраните только один рабочий лист как новый файл Excel с помощью функции перемещения или копирования
Сохраните только один лист в текущей книге с помощью VBA
Сохранить только один лист в текущей книге одним щелчком мыши

Сохраните только один рабочий лист как новый файл Excel с помощью функции перемещения или копирования

Наблюдения и советы этой статьи мы подготовили на основании опыта команды Переместить или скопировать Утилита функции Excel поможет вам легко сохранить определенный рабочий лист как новый файл Excel. Вы можете сделать следующее.

1. Щелкните правой кнопкой мыши вкладку листа (рабочий лист, который необходимо сохранить как новый файл) на панели вкладок листа, затем щелкните Переместить или скопировать.

2. в Переместить или скопировать диалоговом окне выберите (новая книга) из Бронировать раскрывающийся список, проверьте Создать копию поле, а затем щелкните OK кнопка. Смотрите скриншот:

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

Сохраните только один лист в текущей книге с помощью VBA

Если вы хотите удалить все рабочие листы и сохранить только один определенный рабочий лист в текущей книге, следующий код VBA может вам помочь.

1. Нажмите другой + F11 одновременно открыть Microsoft Visual Basic для приложений окно.

2. в Microsoft Visual Basic для приложений окна, нажмите Вставить > Модули. Затем скопируйте и вставьте ниже код VBA в окно модуля.

Код VBA: удалить все листы, кроме определенного, в текущей книге

Sub DeleteSheets1()
    Dim xWs As Worksheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each xWs In Application.ActiveWorkbook.Worksheets
        If xWs.Name <> "test" Then
            xWs.Delete
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Внимание: в коде «тестXNUMX»- это имя рабочего листа, которое нам нужно сохранить только в текущей книге. Пожалуйста, измените его на имя вашего рабочего листа.

3. Нажмите клавишу F5, чтобы запустить код. Затем вы увидите, что все листы в текущих книгах удалены, кроме указанного. А затем сохраните книгу по мере необходимости.

Сохранить только один лист в текущей книге одним щелчком мыши

Наблюдения и советы этой статьи мы подготовили на основании опыта команды Удалить все неактивные листы полезности Kutools for Excel помогает быстро удалить все рабочие листы, кроме текущего, одним щелчком мыши.

1. Перейдите к листу, который нужно оставить только в текущей книге, затем щелкните Кутулс Плюс > Рабочий лист > Удалить все неактивные листы. Смотрите скриншот:

Затем появится диалоговое окно с запросом, если вы решите удалить их, щелкните значок OK кнопку.

Затем все неактивные листы немедленно удаляются из текущей книги.

  Если вы хотите получить бесплатную пробную версию (30-день) этой утилиты, пожалуйста, нажмите, чтобы загрузить это, а затем перейдите к применению операции в соответствии с указанными выше шагами.

Сохранить только один лист

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

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