Function УДАЛИТЬМАКСМИН(диапазон As Range)
Dim arr(), arrItog()
Dim I&, J&
Dim jMax, jMin
arr = диапазон.Value
ReDim arrItog(1 To UBound(arr, 2), 1 To UBound(arr, 1))
For J = LBound(arr, 2) To UBound(arr, 2)
  With Application
    jMax = .Max(.Index(arr, 0, J))
    jMin = .Min(.Index(arr, 0, J))
  End With
  N = 0
  For I = LBound(arr, 1) To UBound(arr, 1)
    If arr(I, J) <> jMax And arr(I, J) <> jMin Then
      N = N + 1
      arrItog(J, N) = arr(I, J)
    End If
  Next
Next
ReDim Preserve arrItog(1 To UBound(arrItog, 1), 1 To N)
УДАЛИТЬМАКСМИН = Application.Transpose(arrItog)
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B1:C1")) Is Nothing And Target.Count = 1 Then
  On Error Resume Next
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Range("A1") = Target
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Function МЛН_РУБ(контракт As Range, листы As Range)
Dim shNames()
Dim iSh As Worksheet
Dim iKey, iTmp
Dim I&, lRow&, N&
Dim arrTmp(), arr()
ReDim arr(0 To Application.Caller.Rows.Count)
With CreateObject("Scripting.Dictionary")
  For Each iKey In листы.Value: iTmp = .Item(iKey): Next
  For Each iSh In ThisWorkbook.Worksheets
    If .Exists(iSh.Name) Then
      With iSh
        lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        lRow = IIf(lRow < 2, 2, lRow)
        arrTmp = .Range("A2:B" & lRow).Value
      End With
      For I = LBound(arrTmp, 1) To UBound(arrTmp, 1)
        If arrTmp(I, 1) = CStr(контракт.Value) Then
          arr(N) = Round(CDbl(arrTmp(I, 2)), 3)
          N = N + 1
        End If
      Next
    End If
  Next
End With
If N < Application.Caller.Rows.Count Then
  ReDim Preserve arr(0 To N - 1)
End If
МЛН_РУБ = Application.Transpose(arr)
End Function