Problem with Median Calculation / VBA Script

M

Mendoza05

Hi,

I am trying to get a Median calculation per group of numbers in a query. I
am a novice at VBA as you will tell from my scripting below but i just get
the feeling its something simple I'm overlooking. Thanks for all your help
in advance!

For Instance:

Table: "Sample_Aging"

R_Number TOTAL
A 5
A 4
A 2
A -3
A 5
B 6
B 5
B 8
B -2
B 4
B 6
B 2
B 6


Wanted Results In Query:
R_Number Median
A Median Result
B Median Result

I am using the following Script:

Option Explicit

Public Function DMedian(FieldName As String, _
TableName As String, _
Optional Criteria As Variant) As Variant

On Error GoTo Err_DMedian
Dim conn As Connection
Dim rs As New ADODB.Recordset
Dim strSQL As String
Dim RowCount As Long
Dim LowMedian As Double, HighMedian As Double

'Open a recordset on the table.
Set conn = CurrentProject.Connection
strSQL = "SELECT " & FieldName & " FROM " & TableName
If Not IsMissing(Criteria) Then
strSQL = strSQL & " WHERE " & Criteria & " ORDER BY " & FieldName
Else
strSQL = strSQL & " ORDER BY " & FieldName
End If
rs.Open strSQL, conn, adOpenKeyset, adLockOptimistic

'Find the number of rows in the table.
rs.MoveLast
RowCount = rs.RecordCount
rs.MoveFirst

'Determine Even or Odd
If RowCount Mod 2 = 0 Then
'There is an even number of records. Determine the low and high
'values in the middle and average them.
rs.Move Int(RowCount / 2) - 1
LowMedian = rs(FieldName)
rs.Move 1
HighMedian = rs(FieldName)
'Return Median
DMedian = (LowMedian + HighMedian) / 2
Else
'There is an odd number of records. Return the value exactly in
'the middle.
rs.Move Int(RowCount / 2)
'Return Median
DMedian = rs(FieldName)
End If

Exit_DMedian:
'close recordset
rs.Close
Exit Function

Err_DMedian:
If Err.Number = 3075 Then
DMedian = 0
Resume Exit_DMedian
ElseIf Err.Number = 3021 Then
'EOF or BOF ie no recordset created
DMedian = -999
Resume Exit_DMedian
Else
MsgBox Err.Description
Resume Exit_DMedian
End If
End Function



In my Query, I am using the following expression:

Median: DMedian("TOTAL","Sample_Aging","[Remit_Number] = "" & [Remit_Number]
& """"")

And I am coming up with the following errors: This module provided above
does compile successfully.

1.) Syntax error in string in query expression: '[Remit_Number] = "&
[Remit_Number] & "ORDER BY TOTAL'

2.) Operation not allowed when object is closed.


I've been trying to fix it for days. I appreciate everyone looking into this!
 
S

Steve Sanford

See if this returns what you want. First, create a new query, switch to SQL
view and paste in the following:


SELECT DISTINCT tblSample_Aging.R_Number,
fCalculateMedian("tblSample_Aging",[R_Number]) AS Median
FROM tblSample_Aging
ORDER BY tblSample_Aging.R_Number
UNION
SELECT DISTINCT " R_Number" AS [All], fCalculateMedian("tblSample_Aging") AS
Median
FROM tblSample_Aging;


(Note: you won't be able to look at this in design view because it is a
Union query)

Next, paste this code in a standard module:

(watch for line wrap)

'----------beg function--------------------------------
Public Function fCalculateMedian(pTable As String, Optional pValue As
Variant) As Double
On Error GoTo Err_DMedian

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim sSQL As String
Dim vRowCount As Integer
Dim vLowMedian As Double
Dim vHighMedian As Double

fCalculateMedian = 0

'create SQL string
If IsMissing(pValue) Then
'this is for all records median
sSQL = "SELECT Total"
sSQL = sSQL & " FROM " & pTable
Else
'by R_Number median
sSQL = "SELECT R_Number, Total"
sSQL = sSQL & " FROM " & pTable
sSQL = sSQL & " WHERE R_Number = '" & pValue & "'"
End If
sSQL = sSQL & " ORDER BY Total"


Set db = CurrentDb()
Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot)

rs.MoveLast
vRowCount = rs.RecordCount

If vRowCount > 0 Then
rs.MoveFirst
If vRowCount Mod 2 = 0 Then 'Even number of Records
'There is an even number of records. Determine the low and high
'values in the middle and average them.
rs.Move Int(vRowCount / 2) - 1
vLowMedian = rs("Total")
rs.MoveNext
vHighMedian = rs("Total")
'Return Median
fCalculateMedian = (vLowMedian + vHighMedian) / 2
Else 'Odd number of Records
'There is an odd number of records. Return the value exactly in
'the middle.
rs.Move Int(vRowCount / 2)
'Return Median
fCalculateMedian = rs("Total")
End If
End If

Exit_DMedian:
'close recordset
On Error Resume Next
rs.Close
Set rs = Nothing
Set db = Nothing
Exit Function

Err_DMedian:
If Err.Number = 3075 Then
fCalculateMedian = 0
Resume Exit_DMedian
ElseIf Err.Number = 3021 Then
'EOF or BOF ie no recordset created
fCalculateMedian = -999
Resume Exit_DMedian
Else
MsgBox Err.Description, Err.Number
Resume Exit_DMedian
End If

End Function
'----------end function--------------------------------


Name the module something like "CalcMedian"


HTH
--
Steve S
--------------------------------
"Veni, Vidi, Velcro"
(I came; I saw; I stuck around.)


Mendoza05 said:
Hi,

I am trying to get a Median calculation per group of numbers in a query. I
am a novice at VBA as you will tell from my scripting below but i just get
the feeling its something simple I'm overlooking. Thanks for all your help
in advance!

For Instance:

Table: "Sample_Aging"

R_Number TOTAL
A 5
A 4
A 2
A -3
A 5
B 6
B 5
B 8
B -2
B 4
B 6
B 2
B 6


Wanted Results In Query:
R_Number Median
A Median Result
B Median Result

I am using the following Script:

Option Explicit

Public Function DMedian(FieldName As String, _
TableName As String, _
Optional Criteria As Variant) As Variant

On Error GoTo Err_DMedian
Dim conn As Connection
Dim rs As New ADODB.Recordset
Dim strSQL As String
Dim RowCount As Long
Dim LowMedian As Double, HighMedian As Double

'Open a recordset on the table.
Set conn = CurrentProject.Connection
strSQL = "SELECT " & FieldName & " FROM " & TableName
If Not IsMissing(Criteria) Then
strSQL = strSQL & " WHERE " & Criteria & " ORDER BY " & FieldName
Else
strSQL = strSQL & " ORDER BY " & FieldName
End If
rs.Open strSQL, conn, adOpenKeyset, adLockOptimistic

'Find the number of rows in the table.
rs.MoveLast
RowCount = rs.RecordCount
rs.MoveFirst

'Determine Even or Odd
If RowCount Mod 2 = 0 Then
'There is an even number of records. Determine the low and high
'values in the middle and average them.
rs.Move Int(RowCount / 2) - 1
LowMedian = rs(FieldName)
rs.Move 1
HighMedian = rs(FieldName)
'Return Median
DMedian = (LowMedian + HighMedian) / 2
Else
'There is an odd number of records. Return the value exactly in
'the middle.
rs.Move Int(RowCount / 2)
'Return Median
DMedian = rs(FieldName)
End If

Exit_DMedian:
'close recordset
rs.Close
Exit Function

Err_DMedian:
If Err.Number = 3075 Then
DMedian = 0
Resume Exit_DMedian
ElseIf Err.Number = 3021 Then
'EOF or BOF ie no recordset created
DMedian = -999
Resume Exit_DMedian
Else
MsgBox Err.Description
Resume Exit_DMedian
End If
End Function



In my Query, I am using the following expression:

Median: DMedian("TOTAL","Sample_Aging","[Remit_Number] = "" & [Remit_Number]
& """"")

And I am coming up with the following errors: This module provided above
does compile successfully.

1.) Syntax error in string in query expression: '[Remit_Number] = "&
[Remit_Number] & "ORDER BY TOTAL'

2.) Operation not allowed when object is closed.


I've been trying to fix it for days. I appreciate everyone looking into this!
Click to expand...
 
M

Mendoza05

Steve,

Thank you so much! It worked perfectly!



Steve Sanford said:
See if this returns what you want. First, create a new query, switch to SQL
view and paste in the following:


SELECT DISTINCT tblSample_Aging.R_Number,
fCalculateMedian("tblSample_Aging",[R_Number]) AS Median
FROM tblSample_Aging
ORDER BY tblSample_Aging.R_Number
UNION
SELECT DISTINCT " R_Number" AS [All], fCalculateMedian("tblSample_Aging") AS
Median
FROM tblSample_Aging;


(Note: you won't be able to look at this in design view because it is a
Union query)

Next, paste this code in a standard module:

(watch for line wrap)

'----------beg function--------------------------------
Public Function fCalculateMedian(pTable As String, Optional pValue As
Variant) As Double
On Error GoTo Err_DMedian

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim sSQL As String
Dim vRowCount As Integer
Dim vLowMedian As Double
Dim vHighMedian As Double

fCalculateMedian = 0

'create SQL string
If IsMissing(pValue) Then
'this is for all records median
sSQL = "SELECT Total"
sSQL = sSQL & " FROM " & pTable
Else
'by R_Number median
sSQL = "SELECT R_Number, Total"
sSQL = sSQL & " FROM " & pTable
sSQL = sSQL & " WHERE R_Number = '" & pValue & "'"
End If
sSQL = sSQL & " ORDER BY Total"


Set db = CurrentDb()
Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot)

rs.MoveLast
vRowCount = rs.RecordCount

If vRowCount > 0 Then
rs.MoveFirst
If vRowCount Mod 2 = 0 Then 'Even number of Records
'There is an even number of records. Determine the low and high
'values in the middle and average them.
rs.Move Int(vRowCount / 2) - 1
vLowMedian = rs("Total")
rs.MoveNext
vHighMedian = rs("Total")
'Return Median
fCalculateMedian = (vLowMedian + vHighMedian) / 2
Else 'Odd number of Records
'There is an odd number of records. Return the value exactly in
'the middle.
rs.Move Int(vRowCount / 2)
'Return Median
fCalculateMedian = rs("Total")
End If
End If

Exit_DMedian:
'close recordset
On Error Resume Next
rs.Close
Set rs = Nothing
Set db = Nothing
Exit Function

Err_DMedian:
If Err.Number = 3075 Then
fCalculateMedian = 0
Resume Exit_DMedian
ElseIf Err.Number = 3021 Then
'EOF or BOF ie no recordset created
fCalculateMedian = -999
Resume Exit_DMedian
Else
MsgBox Err.Description, Err.Number
Resume Exit_DMedian
End If

End Function
'----------end function--------------------------------


Name the module something like "CalcMedian"


HTH
--
Steve S
--------------------------------
"Veni, Vidi, Velcro"
(I came; I saw; I stuck around.)


Mendoza05 said:
Hi,

I am trying to get a Median calculation per group of numbers in a query. I
am a novice at VBA as you will tell from my scripting below but i just get
the feeling its something simple I'm overlooking. Thanks for all your help
in advance!

For Instance:

Table: "Sample_Aging"

R_Number TOTAL
A 5
A 4
A 2
A -3
A 5
B 6
B 5
B 8
B -2
B 4
B 6
B 2
B 6


Wanted Results In Query:
R_Number Median
A Median Result
B Median Result

I am using the following Script:

Option Explicit

Public Function DMedian(FieldName As String, _
TableName As String, _
Optional Criteria As Variant) As Variant

On Error GoTo Err_DMedian
Dim conn As Connection
Dim rs As New ADODB.Recordset
Dim strSQL As String
Dim RowCount As Long
Dim LowMedian As Double, HighMedian As Double

'Open a recordset on the table.
Set conn = CurrentProject.Connection
strSQL = "SELECT " & FieldName & " FROM " & TableName
If Not IsMissing(Criteria) Then
strSQL = strSQL & " WHERE " & Criteria & " ORDER BY " & FieldName
Else
strSQL = strSQL & " ORDER BY " & FieldName
End If
rs.Open strSQL, conn, adOpenKeyset, adLockOptimistic

'Find the number of rows in the table.
rs.MoveLast
RowCount = rs.RecordCount
rs.MoveFirst

'Determine Even or Odd
If RowCount Mod 2 = 0 Then
'There is an even number of records. Determine the low and high
'values in the middle and average them.
rs.Move Int(RowCount / 2) - 1
LowMedian = rs(FieldName)
rs.Move 1
HighMedian = rs(FieldName)
'Return Median
DMedian = (LowMedian + HighMedian) / 2
Else
'There is an odd number of records. Return the value exactly in
'the middle.
rs.Move Int(RowCount / 2)
'Return Median
DMedian = rs(FieldName)
End If

Exit_DMedian:
'close recordset
rs.Close
Exit Function

Err_DMedian:
If Err.Number = 3075 Then
DMedian = 0
Resume Exit_DMedian
ElseIf Err.Number = 3021 Then
'EOF or BOF ie no recordset created
DMedian = -999
Resume Exit_DMedian
Else
MsgBox Err.Description
Resume Exit_DMedian
End If
End Function



In my Query, I am using the following expression:

Median: DMedian("TOTAL","Sample_Aging","[Remit_Number] = "" & [Remit_Number]
& """"")

And I am coming up with the following errors: This module provided above
does compile successfully.

1.) Syntax error in string in query expression: '[Remit_Number] = "&
[Remit_Number] & "ORDER BY TOTAL'

2.) Operation not allowed when object is closed.


I've been trying to fix it for days. I appreciate everyone looking into this!
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Median calculation 2
Median 6
Calculat Median for each data group? 3
Median Function Problem w/ select statement 2
median function 8
Median Calculation, Dates, & Group By 1
my VBA code to calculate median values is broken. :( 3
Having a problem with calculating medians in access 1

Top