Sub SaveSheets()

    Dim ddir, br, fnam, Msg As String
    Dim i As Integer
    ddir = InputBox("Введите путь к создаваемым файлам (Например: C:\MyDocs\)", "Директория", "C:\")
    For i = 1 To Sheets.Count
    Sheets(i).Select
    fnam = ActiveSheet.Name + ".xls"
    If LCase(fnam) = LCase(ActiveWorkbook.Name) Then
       fnam = ActiveSheet.Name + Str(i) + ".xls"
       br = Chr(10) + Chr(13)
       Msg = "Внимание!" + br
       Msg = Msg + "Название сохраняемого документа не может совпадать с уже "+ br
       Msg = Msg + "открытым документом, поэтому название было изменено на" + br
       Msg = Msg + "'" + fnam + "'"
       MsgBox Prompt:=Msg, Buttons:=vbOKOnly + vbInformation
    End If
    fnam = ddir + fnam
    Sheets(i).Copy
    ChDir ddir
    ActiveWorkbook.SaveAs Filename:=fnam, FileFormat:=xlNormal, _
                    Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
                    CreateBackup:=False
    ActiveWorkbook.Close
    Next i
End Sub