Такой вариант
[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]