Sub Оптравить_в_БД()

Dim arr As Variant
Dim arr2 As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False


arr = Array(Range("J1").Value)

   With ActiveWorkbook
   
arr2 = Array(.Name)

Workbooks.Add
ActiveWorkbook.SaveAs FileName:= _
        "\\nas\Departs\_Калькуляции\" & "1_Выгрузка_" & arr(0) & ".xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        Sheets.Add.Name = "Вс"
        Sheets.Add.Name = "РАСЧЕТ"

    Windows(arr2(0)).Activate
    Sheets("РАСЧЕТ").Select
    ActiveSheet.Unprotect "2010"
    Cells.Select
    Selection.Copy
    Windows("1_Выгрузка_" & arr(0) & ".xlsx").Activate
    Sheets("РАСЧЕТ").Select
    Cells.Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    Windows(arr2(0)).Activate
    Sheets("Вс").Select
    Cells.Select
    Selection.Copy
    Windows("1_Выгрузка_" & arr(0) & ".xlsx").Activate
    Sheets("Вс").Select
    Cells.Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("W4:Y4").Select
    Selection.FormulaR1C1 = "=1"
        Sheets("РАСЧЕТ").Select
    ActiveWorkbook.Close SaveChanges:=True
    
    Windows(arr2(0)).Activate

    Sheets("РАСЧЕТ").Select
    Range("A1").Activate
    ActiveSheet.Protect "2010"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
End Sub

Sub Save_Copy_As()   
'---------------------------------------------------------------------------------------   
' Procedure    : Save_Copy_As   
' Author       : Alex_ST   
' Topic_HEADER : Как макросом сохранить копию текущего файла?   
' Topic_URL    : http://www.planetaexcel.ru/forum.php?thread_id=16506   
' DateTime     : 08.02.12, 12:00   
' Purpose      : Сохранение копии активного файла   
' Notes        : Путь сохранения копий хранится в коллекции .Names книги (в именованном диапазоне)   
'---------------------------------------------------------------------------------------   
   Const sPath_in_Names = "Path4SaveCopyAs"   ' имя элемента коллекции .Names, в котором должен храниться путь для сохранения копий файла   
   Dim sSuff$: sSuff = " [" & Format(Now, "yyyy/mm/dd hh-mm'ss''") & "]"    ' суффикс к имени файла копии - дата и время сохренения копии файла   
   Dim FileName, sExp$, sDirPath$, sFullFilePath$, sNewPath$   
   Dim bReadOnlyRecommended As Boolean  
   With ActiveWorkbook   
      FileName = .Name   ' например, "Книга1.xls"   
      sExp = Right(FileName, Len(FileName) - InStrRev(FileName, ".") + 1)   ' расширение файла вместе с точкой (например, ".xls")   
      FileName = Left(FileName, Len(FileName) - Len(sExp)) & sSuff & sExp   ' например, "Книга1 [2012.02.06 15-24'39''].xls"   
      On Error Resume Next  
      sDirPath = .Names(sPath_in_Names).Value   ' считать из коллекции .Names значение, ранее сохраненное под именем sPath_in_Names   
      If Err Then .Names.Add sPath_in_Names, .Path & "\": sDirPath = .Names(sPath_in_Names).Value   ' если считать не удалось, значит путь ранее не задавался и он для первого раза задаётся равным ActiveWorkbook.Path   
      sDirPath = Mid(sDirPath, 3, Len(sDirPath) - 3)   ' убрать из считанного значения в начале "= и в конце "   
      sDirPath = sDirPath & IIf(Right(sDirPath, 1) = "\", "", "\")  ' на всякий случай (если имя было задано в ручную и при этом не верно - без слэша)   
      .Names(sPath_in_Names).Value = sDirPath   ' запомнить путь сохранения копий в коллекции .Names под именем sPath_in_Names   
      sFullFilePath = sDirPath & FileName   ' полный путь сохранения вместе с полным именем копии   
REPEAT_:   
      FileName = Application.GetSaveAsFilename(InitialFileName:=sFullFilePath, _   
                                               FileFilter:="Excel Files (*" & sExp & "), *" & sExp & ", All Files (*.*),*.*", _   
                                               Title:="Сохранение копии файла")   'задать путь сохранения и имя копии файла в окне выбора   
      If VarType(FileName) = vbBoolean Then Exit Sub   ' если нажали "Отмена", то FileName = False, если "Сохранить" - полный путь к файлу вместе с его именем   
      If FileName = .FullName Then MsgBox "Здесь нельзя сохранить файл под таким именем!", 16, "Ошибка": GoTo REPEAT_   
      sDirPath = Left(FileName, InStrRev(FileName, "\"))   ' путь к папке сохранения копий без имени файла   
      .Names(sPath_in_Names).Value = sDirPath   ' запомнить выбранный в диалоге путь в коллекции .Names под именем sPath_in_Names   
      bReadOnlyRecommended = .ReadOnlyRecommended   ' запомнить параметры исходного файла   
      .ReadOnlyRecommended = --(MsgBox("Рекомендовать открывать файл только для чтения?", 36) - 7)   ' MsgBox Argument 4==vbYesNo 32==vbQuestion, MsgBox Return Values: vbYes=6, vbNo=7   
      .SaveCopyAs FileName   
      .ReadOnlyRecommended = bReadOnlyRecommended   ' восстановить параметры исходного файла   
   End With  
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Address = "$A$1" Then MForm1.show
    End If
End Sub

Sub raschet()
Dim XLApp As Object
Set XLApp = CreateObject("Excel.Application")
XLApp.Workbooks.Open ("C:\MyDocs\Расчет.xlsm")
XLApp.Application.Visible = True
XLApp.Application.Run "'Расчет.xlsm'!macro"
XLApp.Workbooks.Close
End Sub

    Set OutMail = OutApp.CreateItem(0)

    'заполняем поля сообщения
    With OutMail
        .To .Cells(i, 1).Offset(1, 52).Value
        .Subject = "Расчетный листок" & "_" & Format(Date, "mmmm/yyyy")
        .Body = ""
        .Attachments.Add ThisWorkbook.Path & "\" & .Cells(i, 1).Offset(1, 0).Value & "_" & Format(Date, "mmmm/yyyy") & ".xlsx"
        .Send
    End With

Sub 1()
If IsEmpty(Range("D202")) = True And (Range("C8:D8") = "перенести") = True Then
    Range("D203").Cut Destination:=Range("D202")
End If
End Sub