Option Compare Binary
Option Explicit

' DMedian and DMode - domain median and mode functions in VBA for
' Access 97. (c) 1999 Andrew J. Perrin, all rights reserved.
' Permission granted for use and distribution with above credit intact.

Public Function DMedian(strField As String, strDomain As String, Optional strWhere As String) As Variant
    Dim qdDomain As QueryDef, rsDomain As Recordset, strSQLText As String, i As Double, tmpMedian As Variant
    Dim vntBookmark As Variant

' Usage: x = DMedian(Expr, Domain, [Criteria])
'   Expr: field or expression to compute median from
'   Domain: name of table or query to select records from
'   Criteria: (optional) WHERE-style clause to select records
'             (Null values excluded automatically)

    On Error GoTo ErrTrap
    strSQLText = "SELECT [" & strField & "] AS MedValue FROM [" & strDomain & "]"
    strSQLText = strSQLText & " WHERE NOT IsNull([" & strField & "])"
    If Len(strWhere) > 0 Then
        strSQLText = strSQLText & " AND " & strWhere
    End If
    strSQLText = strSQLText & " ORDER BY [" & strField & "]"
    Set qdDomain = CurrentDb.CreateQueryDef("", strSQLText)
    Set rsDomain = qdDomain.OpenRecordset
    With rsDomain
        If .RecordCount > 0 Then
            .MoveFirst
            vntBookmark = .Bookmark
            .MoveLast
            i = .RecordCount
            If i / 2 = Int(i / 2) Then
                .Move (i / 2) - 1, vntBookmark
                tmpMedian = !MedValue
                .MoveNext
                tmpMedian = (tmpMedian + !MedValue) / 2
            Else
                .Move Int(i / 2), vntBookmark
                tmpMedian = !MedValue
            End If
        Else
            tmpMedian = Null
        End If
        .Close
    End With
    DMedian = tmpMedian
    Exit Function
ErrTrap:
    DMedian = Null
    MsgBox "DMedian: " & Err.Number & ": " & Err.Description
End Function


Public Function DMode(strField As String, strDomain As String, Optional strWhere As String, _
    Optional Formatted As Boolean = False) As Variant
    Dim qdDomain As QueryDef, rsDomain As Recordset, strSQLText As String, i As Double, tmpMode As Variant
    Dim vntBookmark As Variant, intMaxCount As Integer, vntPrevious As Variant, intCurrent As Integer

' Usage: x = DMode(Expr, Domain, [Criteria], [Formatted])
'   Expr: Field or expression to calculate mode from
'   Domain: table or query to get records from
'   Criteria: (optional) WHERE-style clause to select records
'             (Null records excluded automatically)
'   Formatted: (optional) return a string containing useful
'              information instead of simply the technical mode. Set
'              to true to get this information, leave false to get
'              a variant containing the technical mode value.

    On Error GoTo ErrTrap
    strSQLText = "SELECT [" & strField & "] AS ModeValue FROM [" & strDomain & "]"
    strSQLText = strSQLText & " WHERE NOT IsNull([" & strField & "])"
    If Len(strWhere) > 0 Then
        strSQLText = strSQLText & " AND " & strWhere
    End If
    strSQLText = strSQLText & " ORDER BY [" & strField & "]"
    Set qdDomain = CurrentDb.CreateQueryDef("", strSQLText)
    Set rsDomain = qdDomain.OpenRecordset
    With rsDomain
        If .RecordCount > 0 Then
            .MoveFirst
            tmpMode = !ModeValue
            vntPrevious = !ModeValue
            intCurrent = 1
            intMaxCount = 1
            .MoveNext
            Do While Not .EOF
                If !ModeValue = vntPrevious Then
                    intCurrent = intCurrent + 1
                    If intCurrent = intMaxCount Then
                        tmpMode = "#TIE"
                    ElseIf intCurrent > intMaxCount Then
                        tmpMode = !ModeValue
                        intMaxCount = intCurrent
                    End If
                ElseIf intMaxCount = 1 Then
                    tmpMode = "#NOMODE"
                Else
                    intCurrent = 1
                End If
                vntPrevious = !ModeValue
                .MoveNext
            Loop
        Else
            tmpMode = "#EMPTY"
        End If
        .Close
    End With
    If Formatted Then
        Select Case tmpMode
        Case "#TIE"
            DMode = "Tied at " & intMaxCount & " cases"
        Case "#NOMODE"
            DMode = "Unique cases - no mode"
        Case "#EMPTY"
            DMode = "No records"
        Case Else
            DMode = tmpMode & " (" & intMaxCount & " cases)"
        End Select
    Else
	If Left(tmpMode, 1) = "#" Then
            DMode = Null
        Else
            DMode = tmpMode
        End If
    End If
    Exit Function
ErrTrap:
    DMode = Null
    MsgBox "DMode: " & Err.Number & ": " & Err.Description
End Function