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

Option Compare Text

Function ЧислоПрописью(число As Double, Optional дробная_часть As Integer = 0) As String
'
Dim DROB           ' Дробная часть входящего значения
Dim DROBCHIS As String       ' текст дробной части
Dim CHISLITELNOE As String   ' Результирующее числительное (текст)
Dim CELOE          ' Целая часть входящего значения (текст)
Dim CHAST As String
Dim clValuta As String
Dim drValuta As String
Dim n() As String            ' Отдельная цифра целой части входящего значения (текст)
Dim CIFRA() As String        ' Отдельное числительное (текст)
Dim RAZRJAD() As String      ' Наименование разряда числа (текст)
Dim Znak$
'
If Sgn(число) = -1 Then
  число = Abs(число) ' Если значение отрицательное обрабатывается его абсолютное значение
  Znak = "минус "
End If
  
If Fix(число) = число Then
  число = число + 0.0001
End If
CELOE = Split(Trim$(CStr(число)), Application.DecimalSeparator)(0) ' Удаление пробелов и отбрасывание дробной части
DROB = Split(Trim$(CStr(число)), Application.DecimalSeparator)(1) ' Дробная часть
Select Case Len(DROB)
  Case Is < 3
    DROB = DROB & String(3 - Len(DROB), "0")
  Case Is > 3
    DROB = Left(DROB, 3)
End Select

ReDim n(1 To Len(CELOE)) As String        ' Определение размерности массивов
ReDim CIFRA(Len(CELOE)) As String
ReDim RAZRJAD(Len(CELOE)) As String

CHISLITELNOE = vbNullString
DROBCHIS = vbNullString

CHAST = CELOE
For I = 1 To Len(CELOE)      ' Основной блок процедуры
    n(I) = Mid$(CELOE, Len(CELOE) - I + 1, 1)
    GoSub ObrabotkaRazryadov
Next I

For I = 1 To Len(CELOE) ' Формирование числительного
    CHISLITELNOE = CIFRA(I) & RAZRJAD(I) & CHISLITELNOE
Next I

'Если нужно с Прописной буквы
'Mid$(CHISLITELNOE, 1, 1) = StrConv(Left$(CHISLITELNOE, 1), vbProperCase)

ReDim n(1 To Len(DROB)) As String       ' переопределение размерности массивов
ReDim CIFRA(Len(DROB)) As String

CHAST = DROB

For I = 1 To Len(DROB)     ' преобразование дробной части
    n(I) = Mid$(DROB, Len(DROB) - I + 1, 1)
    GoSub ObrabotkaRazryadov
Next I
    
For I = 1 To Len(DROB) ' Формирование дробной части числительного
    DROBCHIS = CIFRA(I) & Trim$(DROBCHIS)
Next I

If дробная_часть = 0 Then DROBOR = Val(DROB) Else DROBOR = Trim$(DROBCHIS)

clValuta = IIf(clValuta = "", "целых ", clValuta)
drValuta = IIf(drValuta = "", " тысячных", drValuta)

ЧислоПрописью = Znak & CHISLITELNOE & clValuta & DROBOR & drValuta
Exit Function

ObrabotkaRazryadov:   'Подпрограмма обработки разрядов
'       Единицы
    If I = 1 Or I = 4 Or I = 7 Or I = 10 Then
        If Len(CHAST) = 1 And n(I) = "0" Or CHAST = "00" Or CHAST = "000" Then CIFRA(I) = "ноль "
        If n(I) = "1" Then
          CIFRA(I) = "одна "
          If CHAST = CELOE Then clValuta = "целая "
          If CHAST = DROB Then drValuta = " тысячная"
        End If
'            If I = 4 And n(I) = "1" Then CIFRA(I) = "одна "   ' единицы тысяч
        If n(I) = "2" Then CIFRA(I) = "две "
'            If I = 4 And n(I) = "2" Then CIFRA(I) = "две "    ' единицы тысяч
        If n(I) = "3" Then CIFRA(I) = "три "
        If n(I) = "4" Then CIFRA(I) = "четыре "
        If n(I) = "5" Then CIFRA(I) = "пять "
        If n(I) = "6" Then CIFRA(I) = "шесть "
        If n(I) = "7" Then CIFRA(I) = "семь "
        If n(I) = "8" Then CIFRA(I) = "восемь "
        If n(I) = "9" Then CIFRA(I) = "девять "
    End If
'       Десятки
    If I = 2 Or I = 5 Or I = 8 Or I = 11 Then
        If n(I) = "0" Then CIFRA(I) = vbNullString
            
            If n(I) = "1" And n(I - 1) = "0" Then CIFRA(I - 1) = "десять "
            If n(I) = "1" And n(I - 1) = "1" Then CIFRA(I - 1) = "одиннадцать "
            If n(I) = "1" And n(I - 1) = "2" Then CIFRA(I - 1) = "двенадцать "
            If n(I) = "1" And n(I - 1) = "3" Then CIFRA(I - 1) = "тринадцать "
            If n(I) = "1" And n(I - 1) = "4" Then CIFRA(I - 1) = "четырнадцать "
            If n(I) = "1" And n(I - 1) = "5" Then CIFRA(I - 1) = "пятнадцать "
            If n(I) = "1" And n(I - 1) = "6" Then CIFRA(I - 1) = "шестнадцать "
            If n(I) = "1" And n(I - 1) = "7" Then CIFRA(I - 1) = "семнадцать "
            If n(I) = "1" And n(I - 1) = "8" Then CIFRA(I - 1) = "восемнадцать "
            If n(I) = "1" And n(I - 1) = "9" Then CIFRA(I - 1) = "девятнадцать "
            
        If n(I) = "2" Then CIFRA(I) = "двадцать "
        If n(I) = "3" Then CIFRA(I) = "тридцать "
        If n(I) = "4" Then CIFRA(I) = "сорок "
        If n(I) = "5" Then CIFRA(I) = "пятьдесят "
        If n(I) = "6" Then CIFRA(I) = "шестьдесят "
        If n(I) = "7" Then CIFRA(I) = "семьдесят "
        If n(I) = "8" Then CIFRA(I) = "восемьдесят "
        If n(I) = "9" Then CIFRA(I) = "девяносто "
    End If
    If I = 3 Or I = 6 Or I = 9 Or I = 12 Then
'       Сотни
        If n(I) = "0" Then CIFRA(I) = vbNullString
        If n(I) = "1" Then CIFRA(I) = "сто "
        If n(I) = "2" Then CIFRA(I) = "двести "
        If n(I) = "3" Then CIFRA(I) = "триста "
        If n(I) = "4" Then CIFRA(I) = "четыреста "
        If n(I) = "5" Then CIFRA(I) = "пятьсот "
        If n(I) = "6" Then CIFRA(I) = "шестьсот "
        If n(I) = "7" Then CIFRA(I) = "семьсот "
        If n(I) = "8" Then CIFRA(I) = "восемьсот "
        If n(I) = "9" Then CIFRA(I) = "девятьсот "
    End If
    ' Тысячи
    If I = 4 Then
        If Val(n(I)) = 0 Or Val(n(I)) > 4 Then RAZRJAD(I) = "тысяч "
        If Val(n(I)) = 1 Then RAZRJAD(I) = "тысяча "
        If Val(n(I)) >= 2 And Val(n(I)) <= 4 Then RAZRJAD(I) = "тысячи "
    End If
    If I = 5 Then
        If Val(n(I)) = 1 Then RAZRJAD(I - 1) = "тысяч "
    End If
    If I = 6 Then
        If Val(n(I)) = 0 And Val(n(I - 1)) = 0 And Val(n(I - 2)) = 0 Then RAZRJAD(I - 2) = vbNullString
    End If
            ' Миллионы
    If I = 7 Then
        If Val(n(I)) = 0 Or Val(n(I)) > 4 Then RAZRJAD(I) = "миллионов "
        If Val(n(I)) = 1 Then RAZRJAD(I) = "миллион "
        If Val(n(I)) >= 2 And Val(n(I)) <= 4 Then RAZRJAD(I) = "миллиона "
    End If
    If I = 8 Then
        If Val(n(I)) = 1 Then RAZRJAD(I - 1) = "миллионов "
    End If
    If I = 9 Then
        If Val(n(I)) = 0 And Val(n(I - 1)) = 0 And Val(n(I - 2)) = 0 Then RAZRJAD(I - 2) = vbNullString
    End If
            ' Миллиарды
     If I = 10 Then
        If Val(n(I)) = 0 Or Val(n(I)) > 4 Then RAZRJAD(I) = "миллиардов "
        If Val(n(I)) = 1 Then RAZRJAD(I) = "миллиард "
        If Val(n(I)) >= 2 And Val(n(I)) <= 4 Then RAZRJAD(I) = "миллиарда "
    End If
    If I = 11 Then
        If Val(n(I)) = 1 Then RAZRJAD(I - 1) = "миллиардов "
    End If
Return

End Function