Option Explicit

Sub ExtractText_InStr_Mid_Areas()
    Dim rr As Range
    Set rr = Intersect(Selection, ActiveSheet.UsedRange)
    Set rr = Intersect(rr.Columns(1).EntireColumn, rr)
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim cl As Range
    For Each cl In rr.Cells
        cl.Resize(1, 2).Select
        ExtractText_InStr_Mid
    Next
    rr.Select
    Application.Calculation = Application_Calculation
End Sub

Sub ExtractText_InStr_Mid()
Dim txtLower As String, searchLower As String, matchPos%
Dim arr1, ArrChr, ch, I%, pos%
Dim stPos1%, endPos1%, stPos2%, endPos2%
Const Prob As String = " ", kProb As Integer = 2
arr1 = Selection
    
    ArrChr = Array(vbTab, Chr(160))
For Each ch In ArrChr: arr1(1, 1) = Replace(arr1(1, 1), ch, Prob): Next ch
arr1(1, 1) = Application.WorksheetFunction.Trim(arr1(1, 1))
    
txtLower = LCase(arr1(1, 1)): searchLower = LCase(arr1(1, 2))
matchPos = InStr(1, txtLower, searchLower, vbBinaryCompare)
If matchPos = 0 Then MsgBox "Слово не найдено.", vbInformation: Exit Sub

endPos1 = VBA.InStr(matchPos, arr1(1, 1), Prob) - 1
pos = endPos1 + 2
For I = 1 To kProb
        pos = InStr(pos + 1, arr1(1, 1), Prob)
        If pos = 0 Then Exit For
Next I
If pos = 0 Then endPos2 = Len(arr1(1, 1)) Else endPos2 = pos - 1

stPos2 = VBA.InStrRev(arr1(1, 1), Prob, matchPos) + 1
pos = stPos2 - 2
For I = 1 To kProb
        pos = VBA.InStrRev(arr1(1, 1), Prob, pos - 1)
        If pos = 0 Then Exit For
Next I
If pos = 0 Then stPos1 = 1 Else stPos1 = pos + 1
ReDim ArrChr(1)
ArrChr(0) = VBA.Mid(arr1(1, 1), stPos1, endPos1 - stPos1 + 1)
ArrChr(1) = VBA.Mid(arr1(1, 1), stPos2, endPos2 - stPos2 + 1)
Selection.Offset(0, 2) = ArrChr
End Sub

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge <> 1 Then Exit Sub
    If Target.Column <> 3 Then Exit Sub
    If Target.Rows <= 3 Then Exit Sub
    
    If Not IsNumeric(Target.Value) Then Exit Sub
    Application.EnableEvents = False
    Target.FormulaR1C1 = "=SUM(R4C[-2]:RC[-2])*" & Replace(Target.Value, ",", ".")
    Application.EnableEvents = True
End Sub

=ДАТА(ЛЕВСИМВ(D$2;4);3*(МИН(4;ПРОСМОТР(4000;1/(СЖПРОБЕЛЫ(ПСТР(ПОДСТАВИТЬ(D$2;" ";ПОВТОР(" ";20));20*2;20))=РИМСКОЕ(СТРОКА($1:$3999)));СТРОКА($1:$3999)))-1)+1;1)

Sub Печть_листа()
    myPrintSheet ActiveSheet
End Sub

Sub Печать_книги()
    myPrintSheet ActiveWorkbook
End Sub

Private Sub myPrintSheet(sh As Worksheet)
    Const marginMin = 28
    Const marginMax = 70
    Dim yPage As Long
    For yPage = 1 To sh.PageSetup.Pages.Count
        If sh.PageSetup.LeftMargin = marginMax Then
            sh.PageSetup.LeftMargin = marginMin
            sh.PageSetup.RightMargin = marginMax
        Else
            sh.PageSetup.LeftMargin = marginMax
            sh.PageSetup.RightMargin = marginMin
        End If
        sh.PrintOut from:=yPage, To:=yPage
    Next
End Sub

Private Sub myPrintWorkbook(wb As Workbook)
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        myPrintSheet sh
    Next
End Sub

=СУММ(СМЕЩ(Данные!$A2;0;ПОИСКПОЗ($F$5;Данные!$1:$1;0)-1;1;ПОИСКПОЗ($F$6;Данные!$1:$1;0)-ПОИСКПОЗ($F$5;Данные!$1:$1;0)+1))
=СРЗНАЧ(СМЕЩ(Данные!$A3;0;ПОИСКПОЗ($F$5;Данные!$1:$1;0)-1;1;ПОИСКПОЗ($F$6;Данные!$1:$1;0)-ПОИСКПОЗ($F$5;Данные!$1:$1;0)+1))

=СРЗНАЧ(СМЕЩ(Данные!$A3;0;ПОИСКПОЗ($C$5;Данные!$1:$1;0)-1;1;ПОИСКПОЗ($C$6;Данные!$1:$1;0)-ПОИСКПОЗ($C$5;Данные!$1:$1;0)+1))

=СУММ(СМЕЩ(Данные!$A2;0;ПОИСКПОЗ($C$5;Данные!$1:$1;0)-1;1;ПОИСКПОЗ($C$6;Данные!$1:$1;0)-ПОИСКПОЗ($C$5;Данные!$1:$1;0)+1))

Sub Должности()
    Dim tbSource As ListObject
    Set tbSource = ActiveSheet.ListObjects("Таблица1")

    Dim tbTarget As ListObject
    Set tbTarget = ActiveSheet.ListObjects("Таблица24")

    Dim aSour As Variant
    ReDim aSour(1 To 4)
    aSour(1) = tbSource.ListColumns("Фамилия И.О.").DataBodyRange.Value
    aSour(2) = tbSource.ListColumns("ОТ").DataBodyRange.Value
    aSour(3) = tbSource.ListColumns("ДО").DataBodyRange.Value
    aSour(4) = tbSource.ListColumns("должность").DataBodyRange.Value
    
    Dim rSour As Range
    Set rSour = tbSource.ListColumns("должность").DataBodyRange
    
    Dim rTarg As Range
    Set rTarg = tbTarget.ListColumns("должность").DataBodyRange
    rTarg.Cells.ClearContents
    
    Dim aTarg As Variant
    ReDim aTarg(1 To 4)
    aTarg(1) = tbTarget.ListColumns("Фамилия И.О.").DataBodyRange.Value
    aTarg(2) = tbTarget.ListColumns("С").DataBodyRange.Value
    aTarg(3) = tbTarget.ListColumns("ПО").DataBodyRange.Value
    aTarg(4) = tbTarget.ListColumns("должность").DataBodyRange.Value
    
    
    Dim fioY As Object
    Set fioY = CreateObject("Scripting.Dictionary")
    Dim ys As Variant
    For ys = 1 To UBound(aSour(1), 1)
        fioY(aSour(1)(ys, 1)) = fioY(aSour(1)(ys, 1)) & ys & " "
    Next
    
    Dim dtMin As Date, dtMax As Date
    Dim yt As Long, vy As Variant
    For yt = 1 To UBound(aTarg(1), 1)
        
        If fioY.Exists(aTarg(1)(yt, 1)) Then
            For Each vy In Split(fioY(aTarg(1)(yt, 1)), " ")
                If vy <> "" Then
                    ys = CLng(vy)
                    dtMin = WorksheetFunction.Max(aTarg(2)(yt, 1), aSour(2)(ys, 1))
                    dtMax = WorksheetFunction.Min(aTarg(3)(yt, 1), aSour(3)(ys, 1))
                    If dtMin <= dtMax Then
                        aTarg(4)(yt, 1) = aTarg(4)(yt, 1) & rSour.Cells(ys, 1).Address(1, 1, xlA1) & " "
                    End If
                End If
            Next
            
            aTarg(4)(yt, 1) = Trim(aTarg(4)(yt, 1))
            aTarg(4)(yt, 1) = Replace(aTarg(4)(yt, 1), " ", "&"",""&")
            aTarg(4)(yt, 1) = "=" & aTarg(4)(yt, 1)
            rTarg.Cells(yt, 1).Value = aTarg(4)(yt, 1)
        End If
    Next
    
'    rTarg.Value = aTarg(4)
End Sub

=ИНДЕКС($D$1:$D$4;МАКС((A12=$A$3:$A$4)*(B12>=$B$3:$B$4)*(C12<=$C$3:$C$4)*СТРОКА($A$3:$A$4)))

=ЕСЛИ(ОДНОСТРОЧНЫЙ!AG13="О";"О";
                    ЕСЛИ(ОДНОСТРОЧНЫЙ!AG13="16/2";ЕСЛИ(ОДНОСТРОЧНЫЙ!AH$12<>"";"С";"С.");
                                           ЕСЛИ(ОДНОСТРОЧНЫЙ!AG13="8";"Д";"")))

Sub myPrint()
    Dim sh As Worksheet, yPage As Long
    For Each sh In ActiveWorkbook.Worksheets
        For yPage = 1 To sh.PageSetup.Pages.Count
            If sh.PageSetup.LeftMargin = 70 Then
                sh.PageSetup.LeftMargin = 28
                sh.PageSetup.RightMargin = 70
            Else
                sh.PageSetup.LeftMargin = 70
                sh.PageSetup.RightMargin = 28
            End If
            sh.PrintOut from:=yPage, To:=yPage
        Next
    Next
End Sub

Option Explicit

Sub Транспонировать_выделенный()
    If TypeName(Selection) <> "Range" Then Exit Sub
    Transponse_range Selection, Selection.Cells(1, 5)
End Sub

Private Sub Transponse_range(rSource As Range, rTarget As Range)
    On Error Resume Next
    Set rSource = Intersect(rSource.Columns(1).EntireColumn, rSource)
    Set rSource = Intersect(rSource, rSource.Parent.UsedRange)
    On Error GoTo 0
    If rSource Is Nothing Then Exit Sub
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    FillDicFromRange rSource, dic
    If dic.Count = 0 Then Exit Sub
    EditDic dic
    
    ClearTargetRange rSource, rTarget, GetColumnsCount(dic)
    PrintDic dic, rTarget
End Sub
    
Private Sub PrintDic(dic As Object, rTarget As Range)
    Dim trr As Variant
    ReDim trr(1 To dic.Count, 1 To 2 + GetColumnsCount(dic))
    
    Dim yt As Long, xt As Long, xs As Long, nrr As Variant
    For yt = 1 To UBound(trr, 1)
        nrr = Split(dic.Keys()(yt - 1), "#")
        trr(yt, 1) = nrr(0)
        trr(yt, 2) = nrr(1)
        
        xt = 2
        nrr = dic.Items()(yt - 1)
        For xs = LBound(nrr) + 1 To UBound(nrr)
            xt = xt + 1
            trr(yt, xt) = nrr(xs)
        Next
    Next
    
    rTarget.Resize(UBound(trr, 1), UBound(trr, 2)).Value = trr
End Sub
    
Private Function GetColumnsCount(dic As Object) As Long
    Dim nn As Long
    Dim vKey As Variant
    For Each vKey In dic.Keys
        nn = UBound(dic(vKey))
        If GetColumnsCount < nn Then GetColumnsCount = nn
    Next
End Function
    
Private Sub EditDic(dic As Object)
    Dim vKey As Variant
    For Each vKey In dic.Keys
        dic(vKey) = Split(dic(vKey), " ")
    Next
End Sub
    
Private Sub FillDicFromRange(rSource As Range, dic As Object)
    Dim rArea As Range, arr As Variant
    For Each rArea In rSource.Areas
        arr = rArea.Resize(, 3).Value
        FillDicFromArray arr, dic
    Next
End Sub

Private Sub FillDicFromArray(arr As Variant, dic As Object)
    Dim ya As Long, xa As Long, sKey As String
    For ya = 1 To UBound(arr, 1)
        For xa = 1 To UBound(arr, 2)
            If IsError(arr(ya, xa)) Then GoTo bad_row
            If IsEmpty(arr(ya, xa)) Then GoTo bad_row
        Next
        If Not arr(ya, 3) Like "#:##:##" Then GoTo bad_row
        sKey = arr(ya, 1) & "#" & arr(ya, 2)
        dic(sKey) = dic(sKey) & " " & arr(ya, 3)
bad_row:
    Next
End Sub

Private Sub ClearTargetRange(rSource As Range, rTarget As Range, columnsCount As Long)
    Dim rEnd As Range
    Set rEnd = rTarget.Cells(1)
    
    Dim rArea As Range
    For Each rArea In rSource.Areas
        Set rArea = rArea.Cells(rArea.Rows.Count, rArea.Columns.Count)
        If rEnd.Row < rArea.Row Then
            Set rEnd = Intersect(rEnd.EntireColumn, rArea.EntireRow)
        End If
    Next
    
    rTarget.Parent.Range(rTarget.Cells(1), rEnd).Resize(, columnsCount).ClearContents
End Sub

Sub make_prot()
    Const PROT_NAME = "ПРОТОКОЛ"
    
    Dim wb As Workbook
    Set wb = ThisWorkbook ' alias
    
    Dim DA As Boolean
    DA = Application.DisplayAlerts
    Application.DisplayAlerts = False
    On Error Resume Next
    wb.Sheets(PROT_NAME).Delete ' убили старый протокол
    On Error GoTo 0
    Application.DisplayAlerts = DA
     
    Dim ptr As Worksheet: Set ptr = wb.Sheets.Add(After:=wb.Sheets("ОТЧЕТ")) ' лист пересоздали.
    ptr.Name = "ПРОТОКОЛ": ptr.Cells.NumberFormat = "@"
    '
    ' тут пока неважно... пока всё хорошо
    '
    ' а тут начинается интересное
    Dim cmp As Object
    'Application.VBE.MainWindow.Visible = True
    With wb.VBProject.VBComponents: End With
    Set cmp = wb.VBProject.VBComponents(ptr.CodeName).CodeModule
      
    cmp.CreateEventProc "BeforeDoubleClick", "Worksheet"
    Dim lm As Long
    lm = cmp.ProcStartLine("Worksheet_BeforeDoubleClick", 0) + 2
    cmp.InsertLines lm, "Cancel = True"
    cmp.InsertLines lm, "MsgBox ""Ты дважды кликнул."", vbInformation, ""Капитан очевидность сообщает..."""
    
    Application.VBE.MainWindow.Visible = False
    VBEshow "make_prot"
End Sub

Sub VBEshow(ProcName As String, Optional ByRef wb As Workbook = Nothing)
    If wb Is Nothing Then Set wb = ThisWorkbook
    
    Application.WindowState = xlMinimized
    Application.VBE.MainWindow.Visible = True
    Application.VBE.MainWindow.SetFocus
    
    Dim Component As Object
    
    For Each Component In wb.VBProject.VBComponents
        With Component.CodeModule
            On Error Resume Next
                With .ProcStartLine(ProcName, 0): End With
                If Err = 0 Then
                    .CodePane.Show
                    .CodePane.SetSelection .ProcBodyLine(ProcName, 0), 1, .ProcBodyLine(ProcName, 0) + 1, 1 ' _
                                            '.ProcStartLine(ProcName, 0) + .ProcCountLines(ProcName, 0), 1  'Выделить всю процедуру
                    Exit Sub
                End If
            On Error GoTo 0
        End With
    Next
End Sub

Sub make_prot()
'v4
    Const PROT_NAME = "ПРОТОКОЛ"
    
    Dim wb As Workbook
    Set wb = ThisWorkbook ' alias
    
    Dim DA As Boolean
    DA = Application.DisplayAlerts
    Application.DisplayAlerts = False
    On Error Resume Next
    wb.Sheets(PROT_NAME).Delete ' убили старый протокол
    On Error GoTo 0
    Application.DisplayAlerts = DA
     
    Dim ptr As Worksheet: Set ptr = wb.Sheets.Add(After:=wb.Sheets("ОТЧЕТ")) ' лист пересоздали.
    ptr.Name = "ПРОТОКОЛ": ptr.Cells.NumberFormat = "@"
    '
    ' тут пока неважно... пока всё хорошо
    '
    ' а тут начинается интересное
    Dim cmp As Object
    Application.VBE.MainWindow.Visible = True
    Set cmp = wb.VBProject.VBComponents(ptr.CodeName).CodeModule
      
    cmp.CreateEventProc "BeforeDoubleClick", "Worksheet"
    Dim lm As Long
    lm = cmp.ProcStartLine("Worksheet_BeforeDoubleClick", 0) + 2
    cmp.InsertLines lm, "Cancel = True"
    cmp.InsertLines lm, "MsgBox ""Ты дважды кликнул."", vbInformation, ""Капитан очевидность сообщает..."""
    
    Application.VBE.MainWindow.Visible = False
End Sub

Sub make_prot()
'v3
    Const PROT_NAME = "ПРОТОКОЛ"
    
    Dim wb As Workbook
    Set wb = ThisWorkbook ' alias
     
'    DA = Application.DisplayAlerts
    Application.DisplayAlerts = False
    On Error Resume Next
    wb.Sheets(PROT_NAME).Delete ' убили старый протокол
    On Error GoTo 0
    Application.DisplayAlerts = True
     
    Dim ptr As Worksheet: Set ptr = wb.Sheets.Add(After:=wb.Sheets("ОТЧЕТ")) ' лист пересоздали.
    ptr.Name = "ПРОТОКОЛ": ptr.Cells.NumberFormat = "@"
    '
    ' тут пока неважно... пока всё хорошо
    '
    ' а тут начинается интересное
    Dim cmp As Object
    Set cmp = wb.VBProject.VBComponents(ptr.CodeName)
      
    cmp.CodeModule.CreateEventProc "BeforeDoubleClick", "Worksheet"
    Dim lm As Long
    lm = cmp.CodeModule.ProcStartLine("Worksheet_BeforeDoubleClick", 0) + 2
    With cmp.CodeModule
        .InsertLines lm, "Cancel = True"
        .InsertLines lm, "MsgBox ""Ты дважды кликнул."", vbInformation, ""Капитан очевидность сообщает..."""
    End With
    
    Application.VBE.MainWindow.Visible = False
End Sub

Sub make_prot()
'v2
    Const PROT_NAME = "ПРОТОКОЛ"
    
    Dim wb As Workbook
    Set wb = ThisWorkbook ' alias
     
'    DA = Application.DisplayAlerts
    Application.DisplayAlerts = False
    On Error Resume Next
    wb.Sheets(PROT_NAME).Delete ' убили старый протокол
    On Error GoTo 0
    Application.DisplayAlerts = True
     
    Dim ptr As Worksheet: Set ptr = wb.Sheets.Add(After:=wb.Sheets("ОТЧЕТ")) ' лист пересоздали.
    ptr.Name = "ПРОТОКОЛ": ptr.Cells.NumberFormat = "@"
    '
    ' тут пока неважно... пока всё хорошо
    '
    ' а тут начинается интересное
    Dim prj As Object, cmp As Object
    Set prj = wb.VBProject
    Set cmp = prj.VBComponents(ptr.CodeName)
      
    cmp.CodeModule.CreateEventProc "BeforeDoubleClick", "Worksheet"
    Dim lm As Long
    lm = cmp.CodeModule.ProcStartLine("Worksheet_BeforeDoubleClick", 0) + 2
    With cmp.CodeModule
        .InsertLines lm, "Cancel = True"
        .InsertLines lm, "MsgBox ""Ты дважды кликнул."", vbInformation, ""Капитан очевидность сообщает..."""
    End With
End Sub

Sub make_prot()
    Const PROT_NAME = "ПРОТОКОЛ"

    Dim wb As Workbook
    Set wb = ThisWorkbook ' alias
     
'    DA = Application.DisplayAlerts
    Application.DisplayAlerts = False
    On Error Resume Next
    wb.Sheets(PROT_NAME).Delete ' убили старый протокол
    On Error GoTo 0
    Application.DisplayAlerts = True
     
    Dim ptr As Worksheet: Set ptr = wb.Sheets.Add(After:=wb.Sheets("ОТЧЕТ")) ' лист пересоздали.
    ptr.Name = "ПРОТОКОЛ": ptr.Cells.NumberFormat = "@"
    '
    ' тут пока неважно... пока всё хорошо
    '
    ' а тут начинается интересное
    Dim prj As Object, cmp As Object
    Set prj = wb.VBProject
    Set cmp = prj.VBComponents(ptr.CodeName)
      
    With cmp.CodeModule
        Dim lm As Long
        lm = .CreateEventProc("BeforeDoubleClick", "Worksheet")
        .InsertLines lm + 1, "Cancel = True"
        .InsertLines lm + 2, "msgbox ""лист создан"""
        ' и т.д.
    End With
    
End Sub

=СУММЕСЛИМН('Системные события'!$O:$O;'Системные события'!$D:$D;$B:$B;'Системные события'!$L:$L;$3:$3)