Добрый день. В теме Разбить листы на файлы представлен код для нарезки листов одной книги на файлы: [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] В данном коде Имя создаваемого файла = имени листа. Часто мы создаем вспомогательные листы, на которых размещаем справочники, другую исходную информацию. На финальном листе данные формулами подтягиваются из вспомогательных листов. Вспомогательные листы, как правило, делают скрытыми. Как доработать код нарезки файлов, чтобы помимо необходимого листа в отдельный файл копировались все скрытые листы? Спасибо.Мурад
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]
Такой вариант [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]
Код
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]
Тогда перетащим все скрытые листы последними [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