I am a novice in access and VBA. I have a function that I use to calculate the median. The current function acts as a Domain function and uses all data to calculate the median rather than the dataset that makes up the rest of the query/report. I would like to know how to modify this code or a better approach to find the median of dataset used to create the report.
Option Compare Database
Option Explicit
Function DMedian(tName As String, fldName As String) As Single
Dim MedianDB As DAO.Database
Dim ssMedian As DAO.Recordset
Dim RCount As Integer, i As Integer, x As Double, y As Double, _
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
DMedian = ssMedian(fldName)
Else
OffSet = (RCount / 2) - 2
For i = 0 To OffSet
ssMedian.MovePrevious
Next i
x = ssMedian(fldName)
ssMedian.MovePrevious
y = ssMedian(fldName)
DMedian = (x + y) / 2
End If
If Not ssMedian Is Nothing Then
ssMedian.Close
Set ssMedian = Nothing
End If
Set MedianDB = Nothing
End Function
If you are referring to calculating the median against a custom report that you have created, then simply save your query and pass the query name in to 'tname' instead of a table name.
Related
I am trying to find a way to calculate the median of a dataset in access, that is grouped by two columns, typeA, typeB.
This is a sample of the table:
ID (autonumber)
typeA (large number)
typeB (large number)
total (large number)
1
1
1
15
2
2
1
15
3
1
1
45
4
2
1
44
5
1
2
19
6
1
2
4
7
1
2
34
8
2
2
19
9
2
2
18
Using Access 2016
Currently I am using the following code snippet:
Function fMedian(SQLOrTable, GroupFieldName, GroupFieldValue, GroupFieldName2, GroupFieldValue2, MedianFieldName)
DoCmd.SetWarnings False
Dim rs As DAO.Recordset
Set db = CurrentDb
Set rs1 = db.OpenRecordset(SQLOrTable, dbOpenDynaset)
If IsDate(GroupFieldValue) Then
GroupFieldValue = "#" & GroupFieldValue & "#"
ElseIf Not IsNumeric(GroupFieldValue) Then
GroupFieldValue = "'" & Replace(GroupFieldValue, "'", "''") & "'"
End If
If IsDate(GroupFieldValue2) Then
GroupFieldValue2 = "#" & GroupFieldValue2 & "#"
ElseIf Not IsNumeric(GroupFieldValue) Then
GroupFieldValue2 = "'" & Replace(GroupFieldValue2, "'", "''") & "'"
End If
rs1.Filter = GroupFieldName & "=" & GroupFieldValue
rs1.Sort = MedianFieldName
Set rs = rs1.OpenRecordset()
rs.Move (rs.RecordCount / 2)
If rs.RecordCount Mod 2 = 0 Then
varMedian1 = rs.Fields(MedianFieldName)
rs.MoveNext
fMedian = varMedian1 + rs.Fields(MedianFieldName) / 2
Else
fMedian = rs.Fields(MedianFieldName)
End If
End Function
As it stands, this works great for grouping by one column, but I cannot figure out how to allow it to group by on both typeA and typeB. I have by editing the rs1.filter line but to no avail.
Any help with the code, or a better approach would be appreciated.
Thank you!
NOTE: solved using parfaits solution below. added line medianVBA = fmedian before the end of the function.
Consider an extension of #Fionnuala's great answer to calculate median in MS Access by accommodating an open-ended number of grouping variables.
VBA (save below in a standard module of Access project)
Code builds a dynamic SQL string for DAO recordset call for later median calculation. Special handling required for groupings with 0-2 records and null values for groupings.
Public Function MedianVBA(ParamArray Arr() As Variant) As Double
On Error GoTo ErrHandle
Dim N As Long
Dim tblName As String, numCol As String, grpVals As String
Dim strSQL As String
Dim db As DAO.Database, rs As DAO.Recordset
Dim varMedian As Double, fMedian As Double
'BUILD DYNAMIC SQL
tblName = Arr(0)
numCol = Arr(1)
grpVals = " WHERE " & numCol & " IS NOT NULL "
For N = 2 To UBound(Arr) Step 2
If Arr(N + 1) = "" Or IsNull(Arr(N + 1)) Then
grpVals = grpVals & " AND " & Arr(N) & " IS NULL"
ElseIf IsDate(Arr(N + 1)) Then
grpVals = grpVals & " AND " & Arr(N) & " = #" & Arr(N + 1) & "#"
Else
grpVals = grpVals & " AND CStr(" & Arr(N) & ") = '" & Arr(N + 1) & "'"
End If
Next N
strSQL = "SELECT " & numCol _
& " FROM " & tblName _
& grpVals _
& " ORDER BY " & numCol
'CALCULATE MEDIAN
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
If rs.RecordCount = 0 Then
MedianAcc = fMedian
GoTo ExitHandle
ElseIf rs.RecordCount = 1 Then
MedianAcc = rs.Fields(numCol)
GoTo ExitHandle
End If
rs.Move (rs.RecordCount / 2)
rs.MovePrevious
If rs.RecordCount Mod 2 = 0 Then
varMedian = rs.Fields(numCol)
If rs.RecordCount = 2 Then
rs.MoveLast
Else
rs.MoveNext
End If
fMedian = (varMedian + rs.Fields(numCol)) / 2
Else
fMedian = rs.Fields(numCol)
End If
rs.Close
MedianAcc = fMedian
ExitHandle:
Set rs = Nothing: Set db = Nothing
Exit Function
ErrHandle:
MsgBox Err.Number & ": " & Err.Description, vbCritical, "RUNTIME ERROR"
Resume ExitHandle
End Function
Do note, above VBA function uses a ParamArray where first argument expects the source table and second column expects the numeric column and the remaining is open-ended for group column name and value pairs. Signature of call is as follows:
=MedianAcc("table_name",
"numeric_col",
"group1_column", "group1_value",
"group2_column", "group2_value",
...)
SQL (stored query that calls above VBA function)
Below runs a one-group and two-group median calculation.
SELECT t.typeA, t.typeB
, MedianVBA('[myTable]', '[total]', '[typeA]', t.typeA) AS MedianGrp1,
, MedianVBA('[myTable]', '[total]', '[typeA]', t.typeA, '[typeB]', t.typeB) AS MedianGrp2
FROM myTable t
GROUP BY t.typeA, t.typeB
Excuse me taking a totally different approach here...
Say you have a Table called Table1 with fields Field1.
To find the median of Field1 the SQL query would look like this:
SELECT TOP 1
((SELECT MAX(B.Field1) AS Field1 FROM
(SELECT TOP 50 PERCENT A.Field1 FROM Table1 A)
B) +
(SELECT MIN(D.Field1) AS Field1 FROM
(SELECT TOP 50 PERCENT C.Field1 FROM Table1 C ORDER BY C.Field1 DESC)
D))
/2 AS MEDIAN FROM Table1
(the above split out to make it more readable, I wrote it as only 2 lines)
From there all you have to do is write the vba to make it dynamic - replace 'Table1' with your variable SQLorTable and Field1 with the field to find the median of.
I am trying to use this code to calculate median from my query which has these criteria:
<[Form]![testForm2]![crit1] And >[Form]![testForm2]![crit2] and <[Form]![testForm2]![Age1] And >[Form]![testForm2]![Age2]
without these criteria function works well and gives for every task median based on "MP", however when I put in there my criteria I receive error:
error - Too few parameters. Expected 4 and then it says 'Object Variable or With block not set'
my input: DMedian("MP";"testForm2";"[TASK]= '" & [TASK] & "'")
*even when the Form is open it end up with the error.
*I probably need to find a different way to filter this query from the form, but I don't know how
Public Function DMedian(FieldName As String, _
TableName As String, _
Optional Criteria As Variant) As Variant
' Created by Roger J. Carlson
' http://www.rogersaccesslibrary.com
' Terms of use: You may use this function in any application, but
' it must include this notice.
'Returns the median of a given field in a given table.
'Returns -1 if no recordset is created
' You use this function much like the built-in Domain functions
' (DLookUp, DMax, and so on). That is, you must provide the
' 1) field name, 2) table name, and 3) a 'Where' Criteria.
' When used in an aggregate query, you MUST add each field
' in the GROUP BY clause into the into the Where Criteria
' of this function.
' See Help for more on Domain Aggregate functions.
On Error GoTo Err_Median
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Dim RowCount As Long
Dim LowMedian As Double, HighMedian As Double
'Open a recordset on the table.
Set db = CurrentDb
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
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
'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_Median:
'close recordset
rs.Close
Exit Function
Err_Median:
If Err.number = 3075 Then
DMedian = 0
Resume Exit_Median
ElseIf Err.number = 3021 Then
'EOF or BOF ie no recordset created
DMedian = -1
Resume Exit_Median
Else
MsgBox Err.Description
Resume Exit_Median
End If
End Function
The parameter separation character is comma and you are using a semi-colon
CHANGE:
DMedian("MP";"testForm2";"[TASK]= '" & [TASK] & "'")
TO:
DMedian("MP", "testForm2", "[TASK]= '" & [TASK] & "'")
Solution was to refer the text boxes in SQL declaration, Thank you guys
like this:
HAVING (((Data.[REV]< " & Me.crit1 & ") And (Data.[REV])>" & Me.crit2 & ") AND ((Reg.Age)<" & Me.Age1 & " And (Reg.Age)>" & Me.Age2 & " " & SQLcritComplete & "));"
NOT like this:
"HAVING (((Data.[REV]<[Form]![testForm2]![crit1]) And (Data.[REV])>[testForm2]![crit2]) AND ((Reg.Age)<[Form]![testForm2]![Age1] And (Reg.Age)>[Form]![testForm2]![Age2] & SQLcritComplete & "));"
I have a field called "sku" which uniquely identifies products on the table, there are about 38k products. I have a "sku generator" which uses other fields in the table to create the SKU. It's worked perfectly without an issue until I started producing SKUs for a large amount of products. I would launch the generator and it would stop around 15,000 and say "System Resource exceeded" and highlight the following code in the function:
Found = IsNull(DLookup("sku", "Loadsheet", "[sku]='" & TempSKU & "'"))
I didn't have time to fully fix the issue, so a temporary fix for me was to split the database in two, and run the sku generator seperately on both files. Now that I have more time I want to investigate why exactly it gets stuck around this number, and if there's a possibility of fixing this issue (it would save some time with splitting files and then grouping them again). I also have an issue with it getting really slow at times, but I think it's because it's processing so much when it runs. Here is the function
Option Compare Database
Private Sub Command2_Click() 'Generate SKU
Command2.Enabled = False: Command3.Enabled = False: Command2.Caption = "Generating ..."
Me.RecordSource = ""
CurrentDb.QueryDefs("ResetSKU").Execute
Me.RecordSource = "loadsheet_4"
Dim rs As Recordset, i As Long
Set rs = Me.Recordset
rs.MoveLast: rs.MoveFirst
For i = 0 To rs.RecordCount - 1
rs.AbsolutePosition = i
rs.Edit
rs.Fields("sku") = SetSKU(rs)
rs.Update
DoEvents
Next
Command2.Enabled = True: Command3.Enabled = True: Command2.Caption = "Generate SKU"
End Sub
Public Function SetSKU(rs As Recordset) As String
Dim TempStr As String, TempSKU As String, id As Integer, Found As Boolean, ColorFound As Variant
id = 1: ColorFound = DLookup("Abbreviated", "ProductColors", "[Color]='" & rs.Fields("single_color_name") & "'")
TempStr = "ORL-" & UCase(Left(rs.Fields("make"), 2)) & "-"
TempStr = TempStr & Get1stLetters(rs.Fields("model"), True) & rs.Fields("year_dash") & "-L-"
TempStr = TempStr & "WR-"
TempStr = TempStr & IIf(IsNull(ColorFound), "?", ColorFound) & "-4215-2-"
TempStr = TempStr & rs.Fields("color_code")
TempSKU = Replace(TempStr, "-L-", "-" & ADDZeros(id, 2) & "-L-")
Found = IsNull(DLookup("sku", "Loadsheet", "[sku]='" & TempSKU & "'"))
While Found = False
id = id + 1
TempSKU = Replace(TempStr, "-L-", "-" & ADDZeros(id, 2) & "-L-")
Found = IsNull(DLookup("sku", "Loadsheet", "[sku]='" & TempSKU & "'"))
Wend
If id > 1 Then
' MsgBox TempSKU
End If
SetSKU = TempSKU
End Function
Public Function Get1stLetters(Mystr As String, Optional twoLetters As Boolean = False) As String
Dim i As Integer
Get1stLetters = ""
For i = 0 To UBound(Split(Mystr, " ")) 'ubound gets the number of the elements
If i = 0 And twoLetters Then
Get1stLetters = Get1stLetters & UCase(Left(Split(Mystr, " ")(i), 2))
GoTo continueFor
End If
Get1stLetters = Get1stLetters & UCase(Left(Split(Mystr, " ")(i), 1))
continueFor:
Next
End Function
Public Function ADDZeros(N As Integer, MAX As Integer) As String
Dim NL As Integer
NL = Len(CStr(N))
If NL < MAX Then
ADDZeros = "0" & N 'StrDup(MAX - NL, "0") & N
Else: ADDZeros = N
End If
End Function
Notes: This function also calls other functions as well that adds a unique identifier to the SKU and also outputs the first letter of each word of the product
Also I'm running on 64 bit access.
If you require any other info let me know, I didn't post the other functions but if needed let me know.
thanks.
I am not 100% sure how you have split the Database into two files and that you are running the generator on both files. However I have a few suggestion to the function you are using.
I would not pass the recordset object to this function. I would rather pass the ID or unique identifier, and generate the recordset in the function. This could be a good start for efficiency.
Next, declare all objects explicitly, to avoid library ambiguity. rs As DAO.Recordset. Try to make use of inbuilt functions, like Nz().
Could Get1stLetters method be replaced with a simple Left() function? How about ADDZeros method?
Using DLookup might be a bit messy, how about a DCount instead? Could the following be any use now?
Public Function SetSKU(unqID As Long) As String
Dim TempStr As String, TempSKU As String
Dim id As Integer
Dim ColorFound As String
Dim rs As DAO.Recordset
id = 1
Set rs = CurrentDB.OpenRecordset("SELECT single_color_name, make, model, year_dash, color_code " & _
"FROM yourTableName WHERE uniqueColumn = " & unqID)
ColorFound = Nz(DLookup("Abbreviated", "ProductColors", "[Color]='" & rs.Fields("single_color_name") & "'"), "?")
TempStr = "ORL-" & UCase(Left(rs.Fields("make"), 2)) & "-"
TempStr = TempStr & Get1stLetters(rs.Fields("model"), True) & rs.Fields("year_dash") & "-L-"
TempStr = TempStr & "WR-"
TempStr = TempStr & ColorFound & "-4215-2-"
TempStr = TempStr & rs.Fields("color_code")
TempSKU = Replace(TempStr, "-L-", "-" & ADDZeros(id, 2) & "-L-")
While DCount("*", "Loadsheet", "[sku]='" & TempSKU & "'") <> 0
id = id + 1
TempSKU = Replace(TempStr, "-L-", "-" & ADDZeros(id, 2) & "-L-")
Wend
If id > 1 Then
'MsgBox TempSKU'
End If
Set rs = Nothing
SetSKU = TempSKU
End Function
I have the following stored query in MS Access
SELECT
tblRegistration.ID,
tblRegistration.TypeCode,
CDate([tblRegistration].[RegStart]) AS Reg1,
CDate([tblRegistration].[RegStop]) AS Reg2
FROM
tblRegistration
WHERE
(
(tblRegistration.TypeCode = "T" Or tblRegistration.TypeCode = "S" Or tblRegistration.TypeCode = "F")
AND
(CDate([tblRegistration].[RegStart]) Between CDate([Forms]![frmRegBilling]![RegStart]) And CDate([Forms]![frmRegBilling]![RegStop]))
)
OR
(
(tblRegistration.TypeCode = "T" Or tblRegistration.TypeCode = "S" Or tblRegistration.TypeCode = "F")
AND
(CDate([tblRegistration].[RegStop]) Between CDate([Forms]![frmRegBilling]![RegStart]) And CDate([Forms]![frmRegBilling]![RegStop]))
);
The query, when stand alone executed as query (when the frmRegBilling is loaded with the parameters used by the query) shows the proper result (8 records).
But when the query is executed in VBA, only 2 records are shown. In this case, only the first parameter is validated.
Dim qdf As DAO.QueryDef, rst As Recordset, varData As Variant
Dim intFields As Integer, intRecords As Integer, j As Integer, k As Integer
Dim rec As String, fld_type As Integer
Set qdf = CurrentDb.QueryDefs("Query1")
qdf.Parameters(0).Value = Eval(qdf.Parameters(0).Name)
qdf.Parameters(1).Value = Eval(qdf.Parameters(1).Name)
Set rst = qdf.OpenRecordset()
j = rst.RecordCount - 1
k = rst.Fields.Count - 1
Switching the lines Parameter(0) or (1) doesn't help (if of influence for any reason). Why aren't both parameters validated in the query when executed in VBA?
If you are using VBA, why not create this as a Run time Query?
Dim strSQL As String, rst As Recordset, varData As Variant
Dim intFields As Integer, intRecords As Integer, j As Integer, k As Integer
Dim rec As String, fld_type As Integer
strSQL = "SELECT tblRegistration.ID, tblRegistration.TypeCode, CDate([tblRegistration].[RegStart]) AS Reg1, " & _
"CDate([tblRegistration].[RegStop]) AS Reg2 FROM tblRegistration WHERE " & _
"((tblRegistration.TypeCode = 'T' Or tblRegistration.TypeCode = 'S' Or tblRegistration.TypeCode = 'F') AND " & _
"(CDate([tblRegistration].[RegStart]) Between " & Format([Forms]![frmRegBilling]![RegStart], "\#mm\/dd\/yyyy\#") & _
" And " & Format([Forms]![frmRegBilling]![RegStop], "\#mm\/dd\/yyyy\#") & ")) OR " & _
"((tblRegistration.TypeCode = 'T' Or tblRegistration.TypeCode = 'S' Or tblRegistration.TypeCode = 'F') " & _
"AND (CDate([tblRegistration].[RegStop]) Between " & Format([Forms]![frmRegBilling]![RegStart], "\#mm\/dd\/yyyy\#") & _
" And " & Format([Forms]![frmRegBilling]![RegStop], "\#mm\/dd\/yyyy\#") & "));"
Set rst = CurrentDb.OpenRecordset(strSQL)
I'm having an issue with a VBA program I made. I want to create a program which inputs 50,000 records throughout a table (which is the Employee Table in my case), and every time I try to run it, it states an error that says "Compile Error: Duplicate declaration in current scope."
My code is as follows:
Option Compare Database
Option Explicit
Sub arrayData1()
'This subroutine will pump in 50 k records for the first two columns of EMPLOYEE table.
'Also takes in sample names, attempts to clean the data beofre its entered in the table.
'Declare variable by using keyword DIM
Dim EmployeeFNames() As Variant 'implies array. array is always declared variant datatype.
Dim EmployeeLNames() As Variant
Dim EmployeeType() As Variant
Dim num As Integer, dbs As Database, InsertRecord As Variant, num1 As Long
Dim EmployeeID As Long, EmployeeFName As String, EmployeeLName As String, EmployeeType As String, EmployeeWages As Long
'assign value to variables
Set dbs = CurrentDb() 'assign current db(Stage 2 Project)
EmployeeID = 0 'initialise value.
For num1 = 0 To 50000
EmployeeID = EmployeeID + 1 'increment by 1.
EmployeeWages = EmployeeWages + 1
' array is populated with names.
EmployeeFNames = Array("Peter", "Mary", "Frances", "Paul", "Ian", "Ron", "Nathan", "Jesse", "John", "David")
EmployeeLNames = Array("Jacobs", "Smith", "Zane", "Key", "Doe", "Patel", "Chalmers", "Simpson", "Flanders", "Skinner")
EmployeeTypes = Array("Groundskeeper", "Housekeeper", "Concierge", "Front Desk", "Chef", "F&B", "Maintenance", "Accounts", "IT", "Manager")
'Equation for random generation
'INT (upperbound - lowerbound +1) * Rnd + lowerbound) ' upper & lower bound are index values of array
num = Int((9 - 0 + 1) * Rnd + 0) ' equation generates at random a number between 0 & 9.
EmployeeFName = EmployeeFNames(num) ' name is picked at random from array based on random number.
EmployeeLName = EmployeeLNames(num)
EmployeeType = EmployeeTypes(num)
' Use SQL INSERT statement to insert record in EPLOYEE table.
InsertRecord = "INSERT INTO EMPLOYEE(EmployeeID, EmployeeFName, EmployeeLName, EmployeeType, EmployeeWages) VALUES(" _
& "'" & EmployeeID & "'" & "," & "'" & EmployeeFName & "'" & "," & "'" & EmployeeLName & "'" & "," & "'" & EmployeeType & "'" & "," & "'" & EmployeeWages & "'" & ")"
dbs.Execute InsertRecord
Debug.Print EmployeeID; EmployeeFName; EmployeeLName; EmployeeType; EmployeeWages
Next
End Sub
I would appreciate any fixes to this problem and any suggestions towards my code.
You have tried to declare (Dim) the variable EmployeeType as an array of Variant and then later you try to declare it (again) as String.
You'll need to use two different names for those two variables.