Developing.ru

Код: Выделить всё

Sub Сохранить()
    Dim wb As Workbook, wbName As String
    iSheets = Sheets.Count
    Set wb = Excel.Application.ActiveWorkbook
    For i = 1 To iSheets
        wbName = "Лист_" & i
        wb.SaveCopyAs ("C:\Temp\" + wbName + ".xls")
    Next i
    Application.Quit
End Sub

Код: Выделить всё

Sub savSheet()
Const sDir1 = "C:\Temp\", sDir2 = "C:\Temp\TWO\", sSheet = "Лист1"
    If toWB(sDir1 + sSheet + ".xls", sSheet) And toWB(sDir2 + sSheet + ".xls", sSheet) Then
        'файлы скопированы
    Else
        'ошибки при создании файлов
    End If
End Sub
Function toWB(sPath$, sName) As Boolean
On Error Resume Next
    If Len(Dir(sPath)) > 0 Then Kill sPath
    If Err.Number = 0 Then
        Sheets(sName).Copy
        ActiveWorkbook.SaveAs sPath, FileFormat:=xlNormal
        ActiveWindow.Close False
    End If
If Err.Number = 0 Then toWB = True Else Err.Clear
End Function

Код: Выделить всё

Private Sub My_MkDir(iPath$)
    iStart& = 1
    iPathSeparator$ = Application.PathSeparator
    iPath$ = iPath$ & _
             IIf(Right(iPath$, 1) = iPathSeparator$, "", iPathSeparator$)
    Do
        iStart& = InStr(iStart& + 1, iPath$, iPathSeparator$)
        iTempPath$ = Mid(iPath$, 1, iStart&)
        If Dir(iTempPath$, vbDirectory) = "" Then _
           MkDir iTempPath$
    Loop While iStart& <> 0
End Sub
Private Sub Call_My_MkDir()
    My_MkDir "C:\\Temp\Каталог_1\"
    My_MkDir "C:\\Temp\Каталог_2\"
End Sub
Sub СохранитьКнигу2()
    Dim wb As Workbook, wbName As String
    wbName = ActiveWorkbook.Name
    Set wb = Excel.Application.ActiveWorkbook
    Call Call_My_MkDir
    wb.SaveCopyAs ("C:\Temp\Каталог_1\" + wbName)
    wb.SaveCopyAs ("C:\Temp\Каталог_2\" + wbName)
    ActiveWorkbook.Save
    Application.Quit
End Sub