Hi Dave, John and Matthias,
I could not get Matthias' first contribution (1/5/2007) to work properly
after adding additional data to the original set, and comparing the results
with 1.) the median as calculated in Excel and 2.) the 50th percentile
(median) as calculated using Total Access Statistics
http://www.fmsinc.com/products/statistics/index.html
(I have a copy of this software).
Here is my solution, which seems to work. First, create two tables:
tblItemsSold
ID (Autonumber Primary Key)
Item (Text)
NumberSold ()
Price (Currency)
Copy tblItemsSold as tblItemsSoldExcel. You can delete the ID and NumberSold
fields from this table. This table serves as a temporary work table. It would
be best to have such a table in an external linked database to help prevent
DB bloat, but for the present time I have it in the same database. I am using
tblItemsSoldExcel as the source data for the Median function as shown in the
KB article 210581:
How to Use Code to Derive a Statistical Median
http://support.microsoft.com/kb/210581
Here is the code I came up with:
Option Compare Database
Option Explicit
Public Sub Test()
On Error GoTo ProcError
Dim db As DAO.Database
Dim rs1 As DAO.Recordset 'Source data
Dim rs2 As DAO.Recordset 'Re-written data to feed to Median function
Dim intCount As Integer 'Counter
Dim intSold As Integer 'Number of Items Sold for a given item type
Set db = CurrentDb()
' Clear records from ordered table
db.Execute "DELETE * FROM tblItemsSoldExcel", dbFailOnError
Set rs1 = db.OpenRecordset("SELECT Item, NumberSold, Price " & _
"FROM tblItemsSold ORDER BY Price", dbOpenSnapshot)
Set rs2 = db.OpenRecordset("tblItemsSoldExcel", dbOpenDynaset)
If rs1.RecordCount > 0 Then
intSold = rs1("NumberSold")
Do Until rs1.EOF
For intCount = 1 To intSold
With rs2
.AddNew
!Item = rs1("Item")
!Price = rs1("Price")
.Update
End With
Next intCount
rs1.MoveNext
If Not rs1.EOF Then
intSold = rs1("NumberSold")
End If
Loop
MsgBox "The median is: " & _
Format(Median("tblItemsSoldExcel", "Price"), "Currency"), _
vbInformation, "Median Calculation..."
Else
MsgBox "There are no records to calculate a median.", _
vbCritical, "Median Calculation..."
End If
ExitProc:
'Cleanup
On Error Resume Next
rs1.Close: Set rs1 = Nothing
rs2.Close: Set rs2 = Nothing
db.Close: Set db = Nothing
Exit Sub
ProcError:
MsgBox "Error " & Err.Number & ": " & Err.Description, _
vbCritical, "Error in procedure Test..."
Resume ExitProc
End Sub
Function Median(tName As String, fldName As String) As Single
On Error GoTo ProcError
Dim MedianDB As DAO.Database
Dim ssMedian As DAO.Recordset
Dim RCount As Integer
Dim i As Integer
Dim x As Double
Dim y As Double
Dim OffSet As Integer
Set MedianDB = CurrentDb()
Set ssMedian = MedianDB.OpenRecordset("SELECT [" & fldName & _
"] FROM [" & tName & "] WHERE [" & fldName & _
"] IS NOT NULL ORDER BY [" & fldName & "];")
'NOTE: To include nulls when calculating the median value, omit
'WHERE [" & fldName & "] IS NOT NULL from the example.
ssMedian.MoveLast
RCount% = ssMedian.RecordCount
x = RCount Mod 2
If x <> 0 Then
OffSet = ((RCount + 1) / 2) - 2
For i% = 0 To OffSet
ssMedian.MovePrevious
Next i
Median = ssMedian(fldName)
Else
OffSet = (RCount / 2) - 2
For i = 0 To OffSet
ssMedian.MovePrevious
Next i
x = ssMedian(fldName)
ssMedian.MovePrevious
y = ssMedian(fldName)
Median = (x + y) / 2
End If
ExitProc:
'Cleanup
On Error Resume Next
ssMedian.Close: Set ssMedian = Nothing
MedianDB.Close: Set MedianDB = Nothing
Exit Function
ProcError:
MsgBox "Error " & Err.Number & ": " & Err.Description, _
vbCritical, "Error in Median Function..."
Resume ExitProc
End Function
Tom Wickerath
Microsoft Access MVP
http://www.access.qbuilt.com/html/expert_contributors.html
http://www.access.qbuilt.com/html/search.html