Function СУММУНИКЕСЛИМН(rngSumm As Range, rngU As Range, ParamArray Conditions()) As Long
'rngSumm - диапазон суммирования, обязательный
'rngU - диапазон поиска уникальных значений, обязательный
'Conditions() - массив ПАР значений вида: Диапазон_Условий1;Условие1;Диапазон_Условий2;Условие2...Диапазон_УсловийN;УсловиеN, обязательный
'               должен иметь хотя-бы одну пару значений.
'Все диапазоны должны состоять из одного столбца и иметь равное кол-во строк
Dim cl()
Dim arrFlag() As Boolean
Dim I&, J&
Dim rngCond()
Dim arrSumm()
cl = rngU.Value
arrSumm = rngSumm.Value
With CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(cl)
        ReDim arrFlag(Int(UBound(Conditions) / 2))
        For J = LBound(Conditions) To UBound(Conditions) Step 2
            If IsObject(Conditions(J)) Then rngCond = Conditions(J).Value
            If Not IsEmpty(rngCond(I, 1)) Then
            If IsNumeric(rngCond(I, 1)) Then
                If Application.Evaluate(Replace(rngCond(I, 1), ",", ".") & Conditions(J + 1)) Then arrFlag(Int(J / 2)) = True
            Else
                If rngCond(I, 1) Like Conditions(J + 1) Then arrFlag(Int(J / 2)) = True
            End If
            End If
        Next
        If WorksheetFunction.And(arrFlag) = True Then
          .Item(cl(I, 1)) = arrSumm(I, 1)
        End If
    Next
    For Each ikey In .Keys
      СУММУНИКЕСЛИМН = СУММУНИКЕСЛИМН + .Item(ikey)
    Next
End With
End Function

Sub FirstLast()
Dim arr()
Dim dic As Object
Dim arrItog()
Dim iKey, iTmp
Dim I&, J&, N&, U&, dt&, lRow&
On Error Resume Next
Application.ScreenUpdating = False
With ActiveSheet  'если нужные данные на каком-то конкретном листе, а не на Активном,
                  'то замените на такую строку:
                  'With Worksheets("Имя_нужного_листа")
  arr = .Range("A2:G" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
Set dic = CreateObject("Scripting.Dictionary")
For I = LBound(arr, 1) To UBound(arr, 1)
  iKey = IIf(arr(I, 2) >= 80000 And arr(I, 2) <= 190000, arr(I, 1) & "|" & "День", arr(I, 1) & "|" & "Вечер")
  If dic.Exists(iKey) Then
    iTmp = dic(iKey)
    ReDim Preserve iTmp(1 To 7, 1 To UBound(iTmp, 2) + 1)
    For J = 1 To 7: iTmp(J, UBound(iTmp, 2)) = arr(I, J): Next
    dic(iKey) = iTmp
  Else
    ReDim iTmp(1 To 7, 1 To 1)
    For J = 1 To 7: iTmp(J, 1) = arr(I, J): Next
    dic.Add iKey, iTmp
  End If
Next
ReDim arrItog(1 To dic.Count * 2, 1 To 9): I = 1: J = 0: N = 0: U = 0: dt = 0
For Each iKey In dic.Keys
  iTmp = dic(iKey)
  I = I + dt
  arrItog(I, 2) = Split(iKey, "|")(1)
  If arrItog(I, 2) = "День" Then arrItog(I, 1) = CDate(Format(Split(iKey, "|")(0), "@@@@/@@/@@"))
  For J = 0 To 1
    arrItog(I + J, 3) = IIf(J = 0, "Первая", "Последняя")
    U = IIf(J = 0, 1, UBound(iTmp, 2))
    arrItog(I + J, 4) = CDate(Format(iTmp(2, U), IIf(iTmp(2, U) < 100000, "@:@@:@@", "@@:@@:@@")))
    For N = 3 To 7
      arrItog(I + J, N + 2) = iTmp(N, U)
    Next
  Next
  dt = 2
Next
With Worksheets("FirstLast")               ''FirstLast' - это имя листа, куда выгружаются итоговые данные
  lRow = .Cells(.Rows.Count, "I").End(xlUp).Row
  lRow = IIf(lRow < 2, 2, lRow)
  .Range("A2:I" & lRow).ClearContents
  .Range("A2").Resize(dic.Count * 2, 9) = arrItog  'выгружаем результат в ячейку 'A2'
  .Activate
End With
ActiveWindow.DisplayZeros = False
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub

Sub SortSelectedRange()
    Dim Rng As Range
    Dim rngSort As Range
    Dim SortKey As Range
    Dim SortOrientation As XlSortOrientation
    Dim SortOrder As XlSortOrder
    Dim StartTime As Single
    Dim EndTime As Single
    Dim Duration As Single
    Dim Choice As Variant
    Dim KeyColumn As Long
    Dim KeyRow As Long

    ' Проверка наличия выделенного диапазона
    If Selection.Count = 1 Then
        MsgBox "Пожалуйста, выделите диапазон для сортировки.", vbExclamation
        Exit Sub
    End If
    
    ' Ускорение выполнения макроса
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    ' Диалоговое окно для выбора типа сортировки
    Choice = InputBox( _
        "Выберите тип сортировки:" & vbCrLf & vbCrLf & _
        "1: Сортировка по столбцам (по возрастанию)" & vbCrLf & _
        "2: Сортировка по столбцам (по убыванию)" & vbCrLf & _
        "3: Сортировка по строкам (по возрастанию)" & vbCrLf & _
        "4: Сортировка по строкам (по убыванию)", _
        "Выбор сортировки", 1) ' Значение по умолчанию 1

    ' Засекаем время начала выполнения
    StartTime = Timer
    
    ' Обработка выбора пользователя
    SortOrder = IIf((Choice = "1" Or Choice = "3"), xlAscending, xlDescending)
    SortOrientation = IIf((Choice = "1" Or Choice = "2"), xlTopToBottom, xlLeftToRight)
    ' Выполнение сортировки
    Select Case True
        Case Choice = "1" Or Choice = "2"
            Set Rng = Selection.Columns
            For Each rngSort In Rng
              Set SortKey = ActiveSheet.Cells(Rng.Row, rngSort.Column)
              rngSort.Sort Key1:=SortKey, Order1:=SortOrder, Orientation:=SortOrientation, Header:=xlNo
            Next
        Case Choice = "3" Or Choice = "4"
            Set Rng = Selection.Rows
            For Each rngSort In Rng
              Set SortKey = ActiveSheet.Cells(rngSort.Row, Rng.Column)
              rngSort.Sort Key1:=SortKey, Order1:=SortOrder, Orientation:=SortOrientation, Header:=xlNo
            Next
        Case Else
            ' Отмена или неверный ввод
            MsgBox "Сортировка отменена или введен неверный параметр.", vbInformation
            GoTo CleanExit
    End Select
    
    ' Засекаем время окончания выполнения
    EndTime = Timer
    Duration = EndTime - StartTime

    ' Восстановление стандартных настроек Excel
CleanExit:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

    ' Сообщение о времени работы макроса
    If Choice <> "" And Val(Choice) >= 1 And Val(Choice) <= 4 Then
        MsgBox "Макрос выполнен за " & Format(Duration * 1000, "0.00") & " миллисекунд.", vbInformation
    End If

End Sub

Sub MXZ5_Mark17()
Dim arr()
Dim dic As Object
Dim arrItog()
Dim iKey, arrTmp, iTmp
Dim I&, J&, N&, U&, lRow&
Dim Ses$
On Error Resume Next
Application.ScreenUpdating = False
With ActiveSheet  'если нужные данные на каком-то конкретном листе, а не на Активном,
                  'то замените на такую строку:
                  'With Worksheets("Имя_нужного_листа")
  arr = .Range("A2:F" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
Set dic = CreateObject("Scripting.Dictionary")
For I = LBound(arr) To UBound(arr)
  iKey = arr(I, 1)
  If arr(I, 2) >= 80000 And arr(I, 2) <= 190000 Then
    Ses = "Дневная": N = 2
  Else
    Ses = "Вечерняя": N = 8
  End If
  If dic.Exists(iKey) Then
    arrTmp = dic(iKey)
    If N = 2 Then
      U = UBound(arrTmp, 2) + 1
      ReDim Preserve arrTmp(1 To 13, 1 To U)
    Else
      If U = UBound(arrTmp, 2) Then U = 0
      U = U + 1
    End If
    arrTmp(N, U) = Ses
    For J = 2 To 6
      N = N + 1
      arrTmp(N, U) = arr(I, J)
    Next
    dic(iKey) = arrTmp
  Else
    ReDim arrTmp(1 To 13, 1 To 1)
    arrTmp(1, 1) = arr(I, 1)
    arrTmp(N, 1) = Ses
    For J = 2 To 6
      N = N + 1
      arrTmp(N, 1) = arr(I, J)
    Next
    dic.Add iKey, arrTmp
End If
Next

ReDim arrItog(1 To dic.Count, 1 To 15): I = 0: N = 0: J = 0
For Each iKey In dic.keys
    I = I + 1
      iTmp = ArrResize(dic(iKey), 1)(0)
    arrItog(I, 1) = CDate(Format(iTmp, "@@@@/@@/@@"))                               'Дата
    '-----------------------------------------------------------------------------------------------------
    arrItog(I, 2) = arrTmp(2, 1)                                                    'Сессия 'Дневная'
      iTmp = Application.Min(ArrResize(dic(iKey), 3))
    If iTmp <> 0 Then
      arrItog(I, 3) = CDate(Format(iTmp, IIf(iTmp < 100000, "@:@@:@@", "@@:@@:@@")))  'Время открытия сессии
    End If
      iTmp = Application.Max(ArrResize(dic(iKey), 3))
    If iTmp <> 0 Then
      arrItog(I, 4) = CDate(Format(iTmp, IIf(iTmp < 100000, "@:@@:@@", "@@:@@:@@")))  'Время закрытия сессии
    End If
    arrItog(I, 5) = ArrResize(dic(iKey), 4)(0)                                      'Открытие
    arrItog(I, 6) = Application.Max(ArrResize(dic(iKey), 5))                        'Максимальное <HIGH>
    arrItog(I, 7) = Application.Min(ArrResize(dic(iKey), 6))                        'Минимальное <LOW>
      iTmp = ArrResize(dic(iKey), 7)
    arrItog(I, 8) = iTmp(UBound(iTmp))                                              'Закрытие
    '-----------------------------------------------------------------------------------------------------
    arrItog(I, 9) = arrTmp(8, 1)                                                    'Сессия 'Вечерняя'
      iTmp = Application.Min(ArrResize(dic(iKey), 9))
    If iTmp <> 0 Then
      arrItog(I, 10) = CDate(Format(iTmp, IIf(iTmp < 100000, "@:@@:@@", "@@:@@:@@"))) 'Время открытия сессии
    End If
      iTmp = Application.Max(ArrResize(dic(iKey), 9))
    If iTmp <> 0 Then
      arrItog(I, 11) = CDate(Format(iTmp, IIf(iTmp < 100000, "@:@@:@@", "@@:@@:@@"))) 'Время закрытия сессии
    End If
    arrItog(I, 12) = ArrResize(dic(iKey), 10)(0)                                    'Открытие
    arrItog(I, 13) = Application.Max(ArrResize(dic(iKey), 11))                      'Максимальное <HIGH>
    arrItog(I, 14) = Application.Min(ArrResize(dic(iKey), 12))                      'Минимальное <LOW>
      iTmp = ArrResize(dic(iKey), 13)
    arrItog(I, 15) = iTmp(UBound(iTmp))                                              'Закрытие
Next
With Worksheets("Макрос")               ''Макрос' - это имя листа, куда выгружаются итоговые данные
  lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
  lRow = IIf(lRow < 2, 2, lRow)
  .Range("A2:O" & lRow).ClearContents
  .Range("A2").Resize(I, 15) = arrItog  'выгружаем результат в ячейку 'A2'
  .Activate
End With
ActiveWindow.DisplayZeros = False
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub

Private Function ArrResize(iArr, U&)
Dim I&, N&
Dim outArr()
ReDim outArr(0)
For I = LBound(iArr, 2) To UBound(iArr, 2)
  If Not IsEmpty(iArr(U, I)) Then
    ReDim Preserve outArr(N)
    outArr(N) = iArr(U, I)
    N = N + 1
  End If
Next
ArrResize = outArr
End Function