Private Sub WorksheetSaveAsFile()
 
iPath$ = "C:\Мои документы\Архив"
 
If Dir(iPath$, vbDirectory) = "" Then
   MsgBox "Указанная папка " & iPath$ & vbNewLine & _
   "была удалена, перемещена или переименована ", vbExclamation, ""
   Exit Sub
End If
 
On Error GoTo ErrHandler
 
With Application
     .EnableCancelKey = xlDisabled
     .ScreenUpdating = False
     .DisplayAlerts = False
     .EnableEvents = False
     .Calculation = xlManual
     Dim iWorksheet As Worksheet, iHidden As Boolean
     For Each iWorksheet In .ThisWorkbook.Worksheets
         If iWorksheet.Visible <> True Then
            iHidden = True
            iOldVisible& = iWorksheet.Visible
            iWorksheet.Visible = True
         End If
         iWorksheet.Copy
         With .ActiveSheet
              .SaveAs FileName:=iPath$ & "\" & .Name
              .Parent.Close saveChanges:=True
         End With 'Or
         'With .ActiveWorkbook
               '.Close FileName:=iPath$ & "\" & _
               '.ActiveSheet.Name, saveChanges:=True
         'End With
         If iHidden = True Then
            iWorksheet.Visible = iOldVisible&
            iHidden = False 'Not iHidden
         End If
     Next
ErrHandler:
     If Err.Number <> 0 Then
        MsgBox Err.Description, vbCritical, Err.Number
     End If
     .Calculation = xlAutomatic
     .EnableEvents = True
     .DisplayAlerts = True
     .ScreenUpdating = True
     .EnableCancelKey = xlInterrupt
End With
 
End Sub