Функция вычисления медианы
Автор osmor   
27.11.2006 г.
Вычисляет медиану для указанной таблицы или сохраненного запроса по заданному полю.
По использованию аналогична функциям DCount, DMax и т.п.
Option Compare Database
Option Explicit

Public Function DMedian(strNameFiels As String, strNameTBL As String, Optional strFilter As String = "") As Variant
'автор: osmor 27.11.2006 г.
'функция вычисления медианы
'использование аналогично DCount,DMax и т.п.
'strNameFiels - имя поля с данными
'strNameTBL - название таблицы или сохраненного запроса
'strFilter - строка фильтра
Dim dblrez As Double
Dim rst As ADODB.Recordset
Dim lngCount As Long
Dim lngTemp As Double
On Error GoTo Err_dMedian

   lngCount = Nz(DCount("*", strNameTBL, strFilter), 0)
   If lngCount = 0 Then DMedian = Null: Exit Function
   Set rst = New ADODB.Recordset
   rst.Open "select " & strNameFiels & " from " & strNameTBL & IIf(strFilter = "", "", "where " & strFilter) & " order by " & strNameFiels, CurrentProject.Connection, adOpenKeyset, adLockReadOnly
   If (lngCount Mod 2) = 1 Then
    rst.AbsolutePosition = CLng(lngCount \ 2) + 1
    dblrez = Nz(rst.Fields(0), 0)
   Else
    rst.AbsolutePosition = CLng(lngCount \ 2)
    lngTemp = Nz(rst.Fields(0), 0)
    rst.MoveNext
    dblrez = (lngTemp + Nz(rst.Fields(0), 0)) / 2
   End If
   Set rst = Nothing
   DMedian = dblrez
Exit_dMedian:
    Exit Function

Err_dMedian:
    Select Case Err.Number
        Case Else
            MsgBox "(" & Err.Number & ") " & Err.Description & " в процедуре dMedian "
            Resume Exit_dMedian
    End Select

End Function


Просмотров: 9543

  Коментарии (2)
 1 Написал(а) Миша, в 10:27 14.12.2018
Крутая тема, работает, но с большим объемом данных очень долго плужит к сожалению.
 2 Написал(а) Валера, в 19:49 14.07.2019
А можно и вот так: 
 
Public Function SQL_медиана(Поле As String, SQL As String) As Double 
On Error GoTo Ошибка 
 
Dim Записи As ADODB.Recordset 
Set Записи = New ADODB.Recordset 
 
Dim SQL_записи As String 
SQL_записи = \"Select [\" & Поле & \"] From (\" & SQL & \") as Записи Order by [\" & Поле & \"]\" 
\'Debug.Print SQL_записи 
Записи.Open SQL, CurrentProject.Connection, adOpenKeyset, adLockReadOnly 
 
If Записи.RecordCount = 0 Then 
SQL_медиана = 0 
Exit Function 
End If 
 
Dim Записей As Long 
Записей = Nz(Записи.RecordCount, 0) 
 
If Записей = 1 Then 
Записи.MoveFirst 
SQL_медиана = Записи(Поле) 
Exit Function 
End If 
 
If (Записей Mod 2) = 1 Then 
Записи.AbsolutePosition = CLng(Записей \\ 2) + 1 
SQL_медиана = Nz(Записи.fields(Поле), 0) 
Else 
Записи.AbsolutePosition = CLng(Записей \\ 2) 
SQL_медиана = Nz(Записи.fields(Поле), 0) 
Записи.MoveNext 
SQL_медиана = (SQL_медиана + Nz(Записи.fields(Поле), 0)) / 2 
End If 
 
Set Записи = Nothing 
Exit Function 
 
Ошибка: 
SQL_медиана = 0 
Set Записи = Nothing 
 
End Function

Добавить коментарий
Имя:
E-mail
Коментарий:



Код:* Code