Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Нарезка листов на файлы с учетом скрытых листов - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_, DrMini  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Нарезка листов на файлы с учетом скрытых листов (Макросы/Sub)
Нарезка листов на файлы с учетом скрытых листов
Мурад Дата: Среда, 03.05.2017, 17:20 | Сообщение № 1
Группа: Проверенные
Ранг: Ветеран
Сообщений: 513
Репутация: 18 ±
Замечаний: 0% ±

Excel 2007
Добрый день.
В теме Разбить листы на файлы представлен код для нарезки листов одной книги на файлы:
[vba]
Код
Sub Разбить_Листы_на_файлы()
     Dim s As Worksheet
     Dim wb As Workbook
     Set wb = ActiveWorkbook
     For Each s In wb.Worksheets                    'проходим во всем листам активной книги
        s.Copy                    'сохраняем лист как новый файл
        ActiveWorkbook.SaveAs wb.Path & "\" & Sheets(1).Name & ".xlsx"   'сохраняем файл
        ActiveWorkbook.Close
     Next
End Sub
[/vba]
В данном коде Имя создаваемого файла = имени листа.
Часто мы создаем вспомогательные листы, на которых размещаем справочники, другую исходную информацию. На финальном листе данные формулами подтягиваются из вспомогательных листов. Вспомогательные листы, как правило, делают скрытыми.
Как доработать код нарезки файлов, чтобы помимо необходимого листа в отдельный файл копировались все скрытые листы?
Спасибо.
 
Ответить
СообщениеДобрый день.
В теме Разбить листы на файлы представлен код для нарезки листов одной книги на файлы:
[vba]
Код
Sub Разбить_Листы_на_файлы()
     Dim s As Worksheet
     Dim wb As Workbook
     Set wb = ActiveWorkbook
     For Each s In wb.Worksheets                    'проходим во всем листам активной книги
        s.Copy                    'сохраняем лист как новый файл
        ActiveWorkbook.SaveAs wb.Path & "\" & Sheets(1).Name & ".xlsx"   'сохраняем файл
        ActiveWorkbook.Close
     Next
End Sub
[/vba]
В данном коде Имя создаваемого файла = имени листа.
Часто мы создаем вспомогательные листы, на которых размещаем справочники, другую исходную информацию. На финальном листе данные формулами подтягиваются из вспомогательных листов. Вспомогательные листы, как правило, делают скрытыми.
Как доработать код нарезки файлов, чтобы помимо необходимого листа в отдельный файл копировались все скрытые листы?
Спасибо.
Автор - Мурад
Дата добавления - 03.05.2017 в 17:20
_Boroda_ Дата: Среда, 03.05.2017, 18:05 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 16901
Репутация: 6613 ±
Замечаний: ±

2003; 2007; 2010; 2013 RUS
Такой вариант
[vba]
Код
Sub Разбить_Листы_на_файлы()
    Dim sh_ As Worksheet, wb_ As Workbook, ar_
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0
    Set wb_ = ActiveWorkbook
    ReDim ar_(1 To 1)
    For Each sh_ In wb_.Worksheets
        If sh_.Visible <> xlSheetVisible Then
            n_ = n_ + 1
            ReDim Preserve ar_(1 To n_)
            ar_(n_) = sh_.Name
        End If
    Next sh_
    ReDim Preserve ar_(1 To n_ + 1)
    For Each sh_ In wb_.Worksheets
        If sh_.Visible = xlSheetVisible Then
            ar_(n_ + 1) = sh_.Name
            Sheets(ar_).Copy
            ActiveWorkbook.SaveAs wb_.Path & "\" & sh_.Name & ".xlsx"
            ActiveWorkbook.Close
        End If
    Next sh_
    Application.DisplayAlerts = 1
    Application.ScreenUpdating = 1
End Sub
[/vba]

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеТакой вариант
[vba]
Код
Sub Разбить_Листы_на_файлы()
    Dim sh_ As Worksheet, wb_ As Workbook, ar_
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0
    Set wb_ = ActiveWorkbook
    ReDim ar_(1 To 1)
    For Each sh_ In wb_.Worksheets
        If sh_.Visible <> xlSheetVisible Then
            n_ = n_ + 1
            ReDim Preserve ar_(1 To n_)
            ar_(n_) = sh_.Name
        End If
    Next sh_
    ReDim Preserve ar_(1 To n_ + 1)
    For Each sh_ In wb_.Worksheets
        If sh_.Visible = xlSheetVisible Then
            ar_(n_ + 1) = sh_.Name
            Sheets(ar_).Copy
            ActiveWorkbook.SaveAs wb_.Path & "\" & sh_.Name & ".xlsx"
            ActiveWorkbook.Close
        End If
    Next sh_
    Application.DisplayAlerts = 1
    Application.ScreenUpdating = 1
End Sub
[/vba]
Автор - _Boroda_
Дата добавления - 03.05.2017 в 18:05
Мурад Дата: Среда, 03.05.2017, 22:05 | Сообщение № 3
Группа: Проверенные
Ранг: Ветеран
Сообщений: 513
Репутация: 18 ±
Замечаний: 0% ±

Excel 2007
Александр, спасибо!
Все нарезает верно, однако захватывает первый скрытый лист и делает его видимым для каждого файла.
К сообщению приложен файл: 11.xlsx (9.3 Kb)
 
Ответить
СообщениеАлександр, спасибо!
Все нарезает верно, однако захватывает первый скрытый лист и делает его видимым для каждого файла.
Автор - Мурад
Дата добавления - 03.05.2017 в 22:05
_Boroda_ Дата: Среда, 03.05.2017, 23:20 | Сообщение № 4
Группа: Админы
Ранг: Местный житель
Сообщений: 16901
Репутация: 6613 ±
Замечаний: ±

2003; 2007; 2010; 2013 RUS
Тогда перетащим все скрытые листы последними
[vba]
Код
Sub tt()
    Dim sh_ As Worksheet, wb_ As Workbook, ar_
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0
    Set wb_ = ActiveWorkbook
    ReDim ar_(0)
    For Each sh_ In wb_.Worksheets
        If sh_.Visible <> xlSheetVisible Then
            sh_.Move after:=Sheets(wb_.Worksheets.Count)
            n_ = n_ + 1
            ReDim Preserve ar_(0 To n_)
            ar_(n_) = sh_.Name
        End If
    Next sh_
    For Each sh_ In wb_.Worksheets
        If sh_.Visible = xlSheetVisible Then
            ar_(0) = sh_.Name
            Sheets(ar_).Copy
            ActiveWorkbook.SaveAs wb_.Path & "\" & sh_.Name & ".xlsx"
            ActiveWorkbook.Close
        End If
    Next sh_
    Application.DisplayAlerts = 1
    Application.ScreenUpdating = 1
End Sub
[/vba]

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеТогда перетащим все скрытые листы последними
[vba]
Код
Sub tt()
    Dim sh_ As Worksheet, wb_ As Workbook, ar_
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0
    Set wb_ = ActiveWorkbook
    ReDim ar_(0)
    For Each sh_ In wb_.Worksheets
        If sh_.Visible <> xlSheetVisible Then
            sh_.Move after:=Sheets(wb_.Worksheets.Count)
            n_ = n_ + 1
            ReDim Preserve ar_(0 To n_)
            ar_(n_) = sh_.Name
        End If
    Next sh_
    For Each sh_ In wb_.Worksheets
        If sh_.Visible = xlSheetVisible Then
            ar_(0) = sh_.Name
            Sheets(ar_).Copy
            ActiveWorkbook.SaveAs wb_.Path & "\" & sh_.Name & ".xlsx"
            ActiveWorkbook.Close
        End If
    Next sh_
    Application.DisplayAlerts = 1
    Application.ScreenUpdating = 1
End Sub
[/vba]
Автор - _Boroda_
Дата добавления - 03.05.2017 в 23:20
Мурад Дата: Пятница, 05.05.2017, 14:24 | Сообщение № 5
Группа: Проверенные
Ранг: Ветеран
Сообщений: 513
Репутация: 18 ±
Замечаний: 0% ±

Excel 2007
Все работает без ошибок.
Спасибо thumb
 
Ответить
СообщениеВсе работает без ошибок.
Спасибо thumb
Автор - Мурад
Дата добавления - 05.05.2017 в 14:24
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Нарезка листов на файлы с учетом скрытых листов (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2025 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!