Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("r7:r1000")) Is Nothing Then Exit Sub
Cancel = True
Dim s$, i&
With Sheets("История согласования").Rows(Target.Row)
     For i = 6 To 111 Step 5
         If (.Cells(i) <> "") And (.Cells(i + 1) = "") Then
             s = s & .Cells(i) & " " & .Cells(i - 2) & " направл. " & .Cells(i - 1) & vbCrLf
         ElseIf (.Cells(i) <> "") And (.Cells(i + 1) <> "") Or (.Cells(i) = "") And (.Cells(i + 1) <> "") Then
             s = s & .Cells(i + 1) & " " & .Cells(i - 2) & " " & .Cells(i + 2) & " " & .Cells(i - 1) & vbCrLf
         End If
     Next
End With
If s = vbNullString Then Exit Sub
Dim sp, arr()
sp = Split(Mid(s, 1, Len(s) - 1), vbCrLf)
If UBound(sp) = 0 Then MsgBox s, 64: Exit Sub
ReDim arr(1 To UBound(sp) + 1, 1 To 2)
For i = 0 To UBound(sp)
     arr(i + 1, 1) = CDate(Split(sp(i))(0))
     arr(i + 1, 2) = sp(i)
Next i
arr = ShellSort22(arr, 1)
MsgBox Join(Application.Transpose(Application.Index(arr, 0, 2)), Chr(10)), 64
End Sub

Function ShellSort22(x, k As Long)    '*** сортируем 2-мерный массив x по столбцу k
Dim Limit As Long, Switch As Long, i&, j&, u&
Dim ubx&, t
ubx = UBound(x, 2): j = (UBound(x) - LBound(x) + 1) \ 2
Do While j > 0
     Limit = UBound(x) - j
     Do
         Switch = LBound(x) - 1
         For i = LBound(x) To Limit
             If x(i, k) > x(i + j, k) Then    'по возрастанию
                 ' If x(i, k) < x(i + j, k) Then 'по убыванию
                 For u = 1 To ubx
                     t = x(i, u)
                     x(i, u) = x(i + j, u)
                     x(i + j, u) = t
                 Next
                 Switch = i
             End If
         Next
         Limit = Switch - j
     Loop While Switch >= LBound(x)
     j = j \ 2
Loop: ShellSort22 = x
End Function