=ЕСЛИ(И(ГОД(V9)-ГОД(D9)>=14;ГОД(V9)-ГОД(D9)<=16);"КАП";ЕСЛИ(И(ГОД(V9)-ГОД(D9)>=24;ГОД(V9)-ГОД(D9)<=26);"КВР";ЕСЛИ(ГОД(V9)-ГОД(D9)>=46;"ИСКЛ";"ДЭП")))

=26210+(СЕГОДНЯ()-A12)*24

=ИНДЕКС({1:2:11,928:12,768:5:6:7:8:9:10:11:12};МЕСЯЦ(СЕГОДНЯ()))

Sub mrshkei()
Dim arr, arr2, arr3, i As Long, lr As Long, sh As Worksheet, col As New Collection
For Each sh In Worksheets
    lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
    arr = sh.Range("a5:f" & lr)
    For i = LBound(arr) To UBound(arr)
        If arr(i, 1) <> Empty Then
            On Error Resume Next
            col.Add (arr(i, 1) & "::" & arr(i, 2) & "::" & arr(i, 3) & "::" & arr(i, 5) & "::" & arr(i, 6)), _
            CStr(arr(i, 1) & "::" & arr(i, 2) & "::" & arr(i, 3) & "::" & arr(i, 5) & "::" & arr(i, 6))
        End If
    Next i
    ReDim arr2(1 To col.Count, 1 To 6)
    For i = 1 To col.Count
    arr3 = Split(col(i), "::")
        arr2(i, 1) = arr3(0)
        arr2(i, 2) = arr3(1)
        arr2(i, 3) = arr3(2)
        arr2(i, 5) = arr3(3)
        arr2(i, 6) = arr3(4)
        arr2(i, 4) = Application.WorksheetFunction.SumIfs(sh.Columns(4), sh.Columns(1), arr2(i, 1), sh.Columns(2), arr2(i, 2), sh.Columns(3), arr2(i, 3), sh.Columns(5), arr2(i, 5), sh.Columns(6), arr2(i, 6))
    Next i
    sh.Range("A5:F" & lr + 2).ClearContents
    sh.Range("A5").Resize(UBound(arr2), 6) = arr2
    Set col = Nothing
Next sh
End Sub

Sub mrshkei()
Dim arr, arr2, i As Long, n As Long, lr As Long, col As New Collection
lr = Cells(Rows.Count, 6).End(xlUp).Row
arr = Range("F2:I" & lr)
For i = LBound(arr) To UBound(arr)
    If arr(i, 4) <> Empty Then
        On Error Resume Next
        col.Add arr(i, 4), CStr(arr(i, 4))
    End If
Next i
ReDim arr2(0 To UBound(arr) + 1, 1 To 3)
arr2(0, 1) = "Телефон": arr2(0, 2) = "МинДАТА": arr2(0, 3) = "МаксДАТА"
For i = 1 To col.Count
MMax = Application.WorksheetFunction.Min(Columns(6))
MMin = Application.WorksheetFunction.Max(Columns(6))
    For n = LBound(arr) To UBound(arr)
        If col(i) = arr(n, 4) Then
            If MMax < arr(n, 1) Then MMax = arr(n, 1)
            If MMin > arr(n, 1) Then MMin = arr(n, 1)
        End If
    Next n
    arr2(i, 1) = col(i): arr2(i, 2) = MMin: arr2(i, 3) = MMax
Next i
Range("O2").Resize(UBound(arr2) + 1, 3) = arr2
End Sub

Sub sd()
If Range("L15") = 0 And Range("L14") > 0 Then
X = Range("L14") * 2
    Cells(24, X) = Cells(24, X) + 1
End If
End Sub

Sub Перештриховать()
ww = Int((48 * Rnd) + 1)

    ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
    Selection.ShapeRange.Fill.Patterned ww            ' А ТАК НЕ РАБОТАЕТ
 End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("D2")) Is Nothing Then
If Target = Empty Then
    ListObjects("озпшеница").AutoFilter.ShowAllData
Else
    ActiveSheet.ListObjects("озпшеница").Range.AutoFilter Field:=2, Criteria1:=Target.Value
End If
End If
End Sub

Sub drop()
Dim sFolder As String, sFiles As String
Dim i As Long, LR As Long, RV As String
    With Application.FileDialog(msoFileDialogFolderPicker) 'диалоговое окно , с его помощью определяем место сохранения файлов
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With       
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    LR = Cells(Rows.Count, 1).End(xlUp).Row ' определяет последнюю ячейку со значениями в колонке
    For i = 2 To LR Step 4  ' каждые 4 строки начиная со 2 по LR
         RV = Cells(i, 1) 'номер отделения
         Workbooks.Add ' создаёт файл
         ThisWorkbook.Sheets(1).Range(Cells(i, 1), Cells(i + 3, 3)).Copy Destination:=ActiveWorkbook.Sheets(1).Range("B2")   'копирует и вставляет значения
        ActiveWorkbook.SaveAs Filename:=sFolder & "BR " & RV & " Execution", FileFormat:=xlWorkbookNormal
         ActiveWorkbook.Close True 'закрывает и сохраняет
    Next i           
End Sub