Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("B2:B6")) Is Nothing Then
        Application.EnableEvents = False
        Cancel = True
        Target.ClearContents
        Application.EnableEvents = True
    End If
    If Not Intersect(Target, Range("E2:E6")) Is Nothing Then Cancel = True
        Cancel = True
        With Target.Font
            Select Case .ColorIndex
                Case 1: .ColorIndex = 3
                Case 3: .ColorIndex = 1
            End Select
        End With
    End If
End Sub

'Ставим флажок, если был одиночный щелчок по ячейке
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
        If Not Intersect(Target, Range("B2:B6")) Is Nothing Then
            Application.EnableEvents = False
            Target.Font.Name = "Marlett"
            Target = "a"
            Application.EnableEvents = True
        End If
End Sub
 
'Снимаем флажок, если был двойной щелчок по ячейке
'Фамилии менеджеров красным по двойному щелчку
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("B2:B6")) Is Nothing Then
        Application.EnableEvents = False
        Cancel = True
        Target.ClearContents
        Application.EnableEvents = True
    End If
    If Not Intersect(Target, Range("E2:E6")) Is Nothing Then        Cancel = True
        With Target.Interior
            Select Case .Color
                Case vbBlack: .Color = vbRed
                Case vbRed: .Color = vbGreen
                Case vbGreen: .Color = vbBlack
            End Select
        End With
    End If
End Sub

    With Target.Interior
        Select Case .Color
        Case vbBlack: .Color = vbRed
        Case vbRed: .Color = vbBlack
        Case Else: .Color = vbGreen
        End Select
    End With

Public Sub QuickSortNonRecursive___(SortArray())
Dim i As Long, j As Long, lb As Long, ub As Long
Dim stack() As QuickStack, stackpos As Long, ppos As Long, pivot As Variant, swp, maxstack&
    On Error GoTo er
    ReDim stack(1 To 16)
...

Sub t()
Dim arr(1 To 9, 1 To 3), r
r = [a1:c9]
For i = 1 To 9
For j = 1 To 3
arr(i, j) = r(i, j)
Next
Next
Call sort_range(arr)
[a1:c9] = arr
End Sub

Sub test()
Dim tm!, i&, r As Range
Dim arr(1 To 9, 1 To 3), r_arr
Application.ScreenUpdating = False
Set r = [a1:c9]
r_arr = r
For i = 1 To 9
For j = 1 To 3
arr(i, j) = r_arr(i, j)
Next
Next

tm = Timer
For i = 1 To 99
    r.Sort Key1:=Range("C1"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
'Call sort_range(arr)
    r.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
Next
Debug.Print Timer - tm
Application.ScreenUpdating = True
End Sub