Private Sub Workbook_Open()
ThisWorkbook.RefreshAll

Application.Wait Time:=Now + TimeValue("0:02:00")

Dim arrSelSheets(), i As Long
    Application.ScreenUpdating = False
 
 

    SD = Date
    SD = Format(SD, "YYYY.MM.DD")
    
 Worksheets("Booked_out").Range("a1:e100").Columns.AutoFit
 Worksheets("Short").Range("a1:e50").Columns.AutoFit



    ReDim arrSelSheets(1 To ActiveWindow.SelectedSheets.Count)
    For i = 1 To UBound(arrSelSheets)
        arrSelSheets(i) = ActiveWindow.SelectedSheets(i).Name
    Next
     
 
    Worksheets(Array("Booked_out", "Short")).Select
    
    Worksheets(Array("Booked_out", "Short")).Copy
    BreakLinks ActiveWorkbook
    ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & SD & " Check" & ".xlsx"
    ActiveWorkbook.Close False
''
'    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
'        ThisWorkbook.Path & "\" & SD & " Check" & ".pdf", Quality:=xlQualityStandard, _
'        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

    Worksheets(arrSelSheets).Select

    Application.ScreenUpdating = True
'
    
    
    
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
 
    Application.ScreenUpdating = False
    On Error Resume Next

    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
   
    'objOutlookApp.Session.Logon "profile","1234",False, True
    Set objMail = objOutlookApp.CreateItem(0)   '?
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
 
    sTo = "Alexander.Levev@sond.com"
    sSubject = SD & " Check"
    sBody = "Hello, find attached"
    sAttachment = ThisWorkbook.Path & "\" & SD & " Check" & ".pdf"
 
   
    With objMail
        .To = sTo
'        .CC = "Alexander.Levev@sond.com;Stepan.Baev@Sond.com"
        .CC = "Alexey.Ivanov@sond.com"
        .BCC = ""
        .Subject = sSubject
        .Body = sBody
        
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment
            End If
        End If
        .Send
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
    
    
    
    
    
    


End Sub

Sub BreakLinks(wb As Workbook)
    If wb Is Nothing Then Exit Sub
    Dim aLinks As Variant
    aLinks = wb.LinkSources(xlLinkTypeExcelLinks)
    If IsEmpty(aLinks) Then Exit Sub
    Dim v As Variant
    On Error Resume Next
        For Each v In aLinks
            wb.BreakLink v, xlLinkTypeExcelLinks
        Next
    On Error GoTo 0
End Sub

=ИЛИ(
НЕ(ЕОШ(НАЙТИ("!";$C$4)));
НЕ(ЕОШ(НАЙТИ("""";$C$4)));
НЕ(ЕОШ(НАЙТИ("#";$C$4)));
НЕ(ЕОШ(НАЙТИ("$";$C$4)));
НЕ(ЕОШ(НАЙТИ("%";$C$4)));
НЕ(ЕОШ(НАЙТИ("&";$C$4)));
НЕ(ЕОШ(НАЙТИ("'";$C$4)));
НЕ(ЕОШ(НАЙТИ("(";$C$4)));
НЕ(ЕОШ(НАЙТИ(")";$C$4)));
НЕ(ЕОШ(НАЙТИ("*";$C$4)));
НЕ(ЕОШ(НАЙТИ("+";$C$4)));
НЕ(ЕОШ(НАЙТИ(",";$C$4)));
НЕ(ЕОШ(НАЙТИ("-";$C$4)));
НЕ(ЕОШ(НАЙТИ(".";$C$4)));
НЕ(ЕОШ(НАЙТИ("/";$C$4)));
НЕ(ЕОШ(НАЙТИ(":";$C$4)));
НЕ(ЕОШ(НАЙТИ(";";$C$4)));
НЕ(ЕОШ(НАЙТИ("<";$C$4)));
НЕ(ЕОШ(НАЙТИ("=";$C$4)));
НЕ(ЕОШ(НАЙТИ(">";$C$4)));
НЕ(ЕОШ(НАЙТИ("?";$C$4)));
НЕ(ЕОШ(НАЙТИ("@";$C$4)));
НЕ(ЕОШ(НАЙТИ("[";$C$4)));
НЕ(ЕОШ(НАЙТИ("\";$C$4)));
НЕ(ЕОШ(НАЙТИ("]";$C$4)));
НЕ(ЕОШ(НАЙТИ("^";$C$4)));
НЕ(ЕОШ(НАЙТИ("{";$C$4)));
НЕ(ЕОШ(НАЙТИ("|";$C$4)));
НЕ(ЕОШ(НАЙТИ("}";$C$4)));
НЕ(ЕОШ(НАЙТИ("~";$C$4)));
)

=НЕ(ЕОШ(НАЙТИ(A1;$C$4)))

=ИЛИ($B$1:B$30)

=ЕСЛИ(ЕОШ(НАЙТИ("]";ЯЧЕЙКА("filename")));СЖПРОБЕЛЫ(ЛЕВСИМВ(ПОДСТАВИТЬ(СЖПРОБЕЛЫ(ПРАВСИМВ(ПОДСТАВИТЬ(ЯЧЕЙКА("filename";A1);"\";ПОВТОР("  ";255));255));".xls";ПОВТОР("  ";255));255));ПРАВСИМВ(ЯЧЕЙКА("filename";A1);ДЛСТР(ЯЧЕЙКА("filename"))-НАЙТИ("]";ЯЧЕЙКА("filename"))))

C1:C2    =ЛЕВСИМВ(A1;НАЙТИ(" ";A1)-1)
D1:D2    =СЧЁТЕСЛИМН(B:B;C:C)
E1:E6    =СЧЁТЕСЛИМН(C:C;B:B)

Sub ReplaceFormula()
'Выделите ячейки. Запустите макрос.

    Const formula_was = "ЕСЛИ($AC$1=""ДВС"";СУММЕСЛИМН('Расстановка ГШО'!$BI:$BI;'Расстановка ГШО'!$Q:$Q;$C5)/('Расстановка ГШО'!$BI$2-ИНДЕКС('Расстановка ГШО'!$M:$M;ПОИСКПОЗ($C5;'Расстановка ГШО'!$Q:$Q;0)))*($D5-ИНДЕКС('Расстановка ГШО'!$M:$M;ПОИСКПОЗ($C5;'Расстановка ГШО'!$Q:$Q;0)));СУММЕСЛИМН('Расстановка ГШО'!$BJ:$BJ;'Расстановка ГШО'!$Q:$Q;$C5)/('Расстановка ГШО'!$BI$2-ИНДЕКС('Расстановка ГШО'!$M:$M;ПОИСКПОЗ($C5;'Расстановка ГШО'!$Q:$Q;0)))*($D5-ИНДЕКС('Расстановка ГШО'!$M:$M;ПОИСКПОЗ($C5;'Расстановка ГШО'!$Q:$Q;0))))"
    Const formula_must = "A2"

    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual

    Dim cl As Range
    For Each cl In Selection.SpecialCells(xlCellTypeFormulas).Cells
        If InStr(cl.FormulaLocal, formula_was) > 0 Then
            cl.FormulaLocal = Replace(cl.FormulaLocal, formula_was, formula_must)
        End If
    Next
    
    Application.Calculation = Application_Calculation
End Sub

=ПСТР(A1;3;2)
=ЗНАЧЕН(ПСТР(A1;3;2))

Sub Макрос1()
    Dim ii As Long
    For ii = 1 To 100
        ActiveSheet.Copy After:=Sheets(Sheets.Count)
    Next
End Sub

=(ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1)+1;6)-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);6))/((ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1)+1;2)-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);2)))*(N4-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);2))+ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);6)

=(ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1)+1;6)-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);6))/((ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1)+1;2)-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);2)))*(N4-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);2))+ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);6)

O5:O20    =O4+(СЧЁТЕСЛИМН(C$3:C4;C5;E$3:E4;E5;G$3:G4;G5;I$3:I4;I5)=0)

O5:O20    =O4+(СЧЁТЕСЛИМН(C$3:C4;C5;E$3:E4;E5;G$3:G4;G5;I$3:I4;I5)=0)
B24:C39    =ЕСЛИОШИБКА(ИНДЕКС(СМЕЩ($A$5:$A$20;0;ПОИСКПОЗ($23:$23;$4:$4;0)-1);ПОИСКПОЗ($A:$A;$O$5:$O$20;0));"")
E24:G39    =ЕСЛИОШИБКА(ИНДЕКС(СМЕЩ($A$5:$A$20;0;ПОИСКПОЗ($23:$23;$4:$4;0)-1);ПОИСКПОЗ($A:$A;$O$5:$O$20;0));"")
H24:H39    =СУММЕСЛИМН($L$5:$L$20;$C$5:$C$20;$C$23:$C$39;$E$5:$E$20;$E$23:$E$39;$G$5:$G$20;$F$23:$F$39;$I$5:$I$20;$G$23:$G$39)

="@"&ПОДСТАВИТЬ(F1;СИМВОЛ(10);"@"&СИМВОЛ(10)&"@")&"@"

=ЕСЛИОШИБКА(ЕСЛИ(СОВПАД(A$1;ЛЕВСИМВ($E2;ПОИСК(":";$E2)-1));ПРАВСИМВ($E2;ДЛСТР($E2)-ПОИСК(":";$E2));"");"")&
ЕСЛИОШИБКА(ЕСЛИ(СОВПАД(A$1;ЛЕВСИМВ($F2;ПОИСК(":";$F2)-1));ПРАВСИМВ($F2;ДЛСТР($F2)-ПОИСК(":";$F2));"");"")&
ЕСЛИОШИБКА(ЕСЛИ(СОВПАД(A$1;ЛЕВСИМВ($G2;ПОИСК(":";$G2)-1));ПРАВСИМВ($G2;ДЛСТР($G2)-ПОИСК(":";$G2));"");"")&
ЕСЛИОШИБКА(ЕСЛИ(СОВПАД(A$1;ЛЕВСИМВ($H2;ПОИСК(":";$H2)-1));ПРАВСИМВ($H2;ДЛСТР($H2)-ПОИСК(":";$H2));"");"")

Sub DeleteEmptyRows()
    CloseEmptyWb
    ActiveSheet.Copy
    
    Dim rSelect As Range
    Set rSelect = Intersect(Selection, ActiveSheet.UsedRange)
    
    Dim rEntRow As Range
    Set rEntRow = Intersect(rSelect.EntireRow, ActiveSheet.UsedRange)
    
    Dim aSelect As Variant
    Dim aEntRow As Variant
    Dim oEntRow As Variant
    
    aSelect = GetArrayFromRange(rSelect)
    aEntRow = GetArrayFromRange(rEntRow)
    ReDim oEntRow(1 To UBound(aEntRow, 1), 1 To UBound(aEntRow, 2))
    
    Dim flag As Boolean
    Dim xa As Long
    Dim ya As Long
    Dim yo As Long
    For ya = 1 To UBound(aSelect, 1)
        flag = False
        For xa = 1 To UBound(aSelect, 2)
            If Not IsEmpty(aSelect(ya, xa)) Then
                flag = True
                Exit For
            End If
        Next
        If flag Then
            yo = yo + 1
            For xa = 1 To UBound(aEntRow, 2)
                oEntRow(yo, xa) = aEntRow(ya, xa)
            Next
        End If
    Next
    rEntRow = oEntRow
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Private Function GetArrayFromRange(rr As Range) As Variant
    Dim arr As Variant
    If rr.Cells.CountLarge = 1 Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = rr.Value
    Else
        arr = rr.Value
    End If
    GetArrayFromRange = arr
End Function

=РАБДЕНЬ(B2;1;$A$2:$A$26)

=РАБДЕНЬ_ПЛЮСПРАЗД(B2;1;$A$2:$A$26;$D$2:$D$26)

Function РАБДЕНЬ_ПЛЮСПРАЗД(нач_дата As Date, число_дней As Long, праздники As Range, рабочие_выходные As Range) As Date
    Dim flag As Boolean
    Dim dt As Date
    Dim ii As Long
    dt = нач_дата
    Do
        If ii >= число_дней Then Exit Do
        dt = dt + 1
        If WorksheetFunction.CountIfs(праздники, dt) > 0 Then
            flag = False
        ElseIf WorksheetFunction.CountIfs(рабочие_выходные, dt) > 0 Then
            flag = True
        ElseIf WorksheetFunction.Weekday(dt, 2) > 5 Then
            flag = False
        Else
            flag = True
        End If
        If flag Then ii = ii + 1
    Loop
    РАБДЕНЬ_ПЛЮСПРАЗД = dt
End Function

=РАБДЕНЬ_ПЛЮСПРАЗД(A2;5;$F$6:$F$9;$F$11)

=ЕСЛИ(ОСТАТ(СТОЛБЕЦ()-СТОЛБЕЦ($I$1)-МЕСЯЦ($D5)+1;12)=0;3;
ЕСЛИ(ОСТАТ(СТОЛБЕЦ()-СТОЛБЕЦ($I$1)-МЕСЯЦ($D5)+1;6)=0;2;
ЕСЛИ(ОСТАТ(СТОЛБЕЦ()-СТОЛБЕЦ($I$1)-МЕСЯЦ($D5)+1;1)=0;1;0)))

Sub AddSumRows()
    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    CloseEmptyWb
    ActiveSheet.Copy
    AddSumRows_sheet ActiveSheet
    
    Application.Calculation = Application_Calculation
End Sub

Private Sub AddSumRows_sheet(sh As Worksheet)
    Dim xa As Long
    xa = GetCashNumberColumn(sh)
    With sh
        Dim ya As Long
        ya = .Cells(.Rows.Count, xa).End(xlUp).Row
        
        If ya = 1 Then
            CloseEmptyWb
            Exit Sub
        End If
        Dim arr As Variant
        arr = .Cells(1, xa).Resize(ya).Value
    End With

    AddSumRows_Array arr, sh, xa
End Sub

Private Function GetCashNumberColumn(sh As Worksheet) As Long
    Dim xx As Long
    On Error Resume Next
    xx = sh.UsedRange.Find("№ кассового документа").Column
    On Error GoTo 0
    If xx = 0 Then xx = [G1].Column
    
    GetCashNumberColumn = xx
End Function

Private Sub AddSumRows_Array(arr As Variant, sh As Worksheet, xa As Long)
    Dim yb As Long
    Dim ya As Long
    For ya = UBound(arr, 1) To 1 Step -1
        For yb = ya - 1 To 1 Step -1
            If arr(yb, 1) <> arr(ya, 1) Then
                Exit For
            End If
        Next
        yb = yb + 1
        If yb < ya Then
            AddSumRows_Row sh, ya + 1, xa, arr(ya, 1), ya - yb + 1
            ya = yb
        End If
    Next
End Sub

Private Sub AddSumRows_Row(sh As Worksheet, ya As Long, xa As Long, vVal As Variant, yd As Long)
    With sh
        .Rows(ya).Insert
        .Cells(ya, 1).Resize(1, xa - 1).Merge
        .Cells(ya, 1).Value = "Итого: "
        .Cells(ya, xa).Resize(1, 2).Merge
        .Cells(ya, xa).Value = vVal
        .Cells(ya, xa + 2).FormulaR1C1 = "=SUM(R[-1]C:R[-" & yd & "]C)"
        .Cells(ya, 1).Resize(1, xa + 2).Font.Bold = True
    End With
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub