Sub Copy_Sheet_File()
 
Dim wbFirst As Workbook, wbSecond As Workbook
 
Dim shToCopy As Worksheet
 
Dim NameFile As String, NameDirectory As String
 
 
Application.ScreenUpdating = False
NameFile = Format(Now, "dd-mm-yy")
Set wbFirst = ActiveWorkbook
NameDirectory = wbFirst.Path & "\" & Left(wbFirst.Name, Len(wbFirst.Name) - 4) & " " & NameFile
 
MkDir NameDirectory
 
For Each shToCopy In wbFirst.Worksheets
 
 If shToCopy.Visible = xlSheetVisible Then
  shToCopy.Copy
  Set wbSecond = ActiveWorkbook
  wbSecond.SaveAs NameDirectory & "\" & wbSecond.Sheets(1).Name & ".xls"
  wbSecond.Close False
 End If
 
Next shToCopy
 
MsgBox "Âñå ëèñòû èç êíèãè-èñòî÷íèêà ñîõðàíåíû â ïàïêå " & NameDirectory
 
End Sub