SQL for Aggregate 25 percentile value for subsets in MS Access?

[mountainclimber]

It looks like there is no Qualtile function in access. But this article seems to be able to call Qualtile function in access using Access.


http://www.mrexcel.com/forum/microso...-function.html

If I can get it working, I will pass it along.

Yes, I saw that a while back. In that same thread there is a post (#7) that has a SQL based percentile. I think I may give both a try and try to figure out with is faster. Speed is an issue for me as I have to do this calculations many times every day. Good post, thanks! If I sort it out, I'll try to post results here too.

[mountainclimber]

Just to finish up this thread, this is how I ended up:

Option ExplicitSub test()
Dim x


'slower way .........................................  Excel created each time and queries executed each time .....................


'x = Now
'    Debug.Print DCalculate("Percentile", "tbl_DatedModel_2015_0702_0", "GM", "[GM] IS NOT NULL AND [GICS Sector] = " & VBA.Chr(34) & "Consumer Discretionary" & VBA.Chr(34), , 0.25)
'    Debug.Print DCalculate("Percentile", "tbl_DatedModel_2015_0702_0", "GM", "[GM] IS NOT NULL AND [GICS Sector] = " & VBA.Chr(34) & "Consumer Discretionary" & VBA.Chr(34), , 0.5)
'    Debug.Print DCalculate("Percentile", "tbl_DatedModel_2015_0702_0", "GM", "[GM] IS NOT NULL AND [GICS Sector] = " & VBA.Chr(34) & "Consumer Discretionary" & VBA.Chr(34), , 0.75)
'
'    Debug.Print DCalculate("Median", "tbl_DatedModel_2015_0702_0", "GM", "[GM] IS NOT NULL AND [GICS Sector] = " & VBA.Chr(34) & "Consumer Discretionary" & VBA.Chr(34))
'
'    Debug.Print DCalculate("Kurtosis", "tbl_DatedModel_2015_0702_0", "GM", "[GM] IS NOT NULL AND [GICS Sector] = " & VBA.Chr(34) & "Consumer Discretionary" & VBA.Chr(34))
'
'    Debug.Print DCalculate("Minimum", "tbl_DatedModel_2015_0702_0", "GM", "[GM] IS NOT NULL AND [GICS Sector] = " & VBA.Chr(34) & "Consumer Discretionary" & VBA.Chr(34))
'    Debug.Print DCalculate("Maximum", "tbl_DatedModel_2015_0702_0", "GM", "[GM] IS NOT NULL AND [GICS Sector] = " & VBA.Chr(34) & "Consumer Discretionary" & VBA.Chr(34))
'
'    Debug.Print DCalculate("IQR", "tbl_DatedModel_2015_0702_0", "GM", "[GM] IS NOT NULL AND [GICS Sector] = " & VBA.Chr(34) & "Consumer Discretionary" & VBA.Chr(34))
'
'
'    Debug.Print DCalculate("Skewness", "tbl_DatedModel_2015_0702_0", "GM", "[GM] IS NOT NULL AND [GICS Sector] = " & VBA.Chr(34) & "Consumer Discretionary" & VBA.Chr(34))
'    Debug.Print DCalculate("StDev", "tbl_DatedModel_2015_0702_0", "GM", "[GM] IS NOT NULL AND [GICS Sector] = " & VBA.Chr(34) & "Consumer Discretionary" & VBA.Chr(34))
'    Debug.Print DCalculate("Mean", "tbl_DatedModel_2015_0702_0", "GM", "[GM] IS NOT NULL AND [GICS Sector] = " & VBA.Chr(34) & "Consumer Discretionary" & VBA.Chr(34))
'
'    'NAs won't be found here b/c there are no null values
''    Debug.Print DCalculate("Obs", "tbl_DatedModel_2015_0702_0", "GM", "[GM] IS NOT NULL AND [GICS Sector] = " & VBA.Chr(34) & "Consumer Discretionary" & VBA.Chr(34))
''    Debug.Print DCalculate("PctNull", "tbl_DatedModel_2015_0702_0", "GM", "[GM] IS NOT NULL AND [GICS Sector] = " & VBA.Chr(34) & "Consumer Discretionary" & VBA.Chr(34))
'
'    'NAs will be found here b/c there will be null values
'    Debug.Print DCalculate("Obs", "tbl_DatedModel_2015_0702_0", "GM", "[GICS Sector] = " & VBA.Chr(34) & "Consumer Discretionary" & VBA.Chr(34))
'    Debug.Print DCalculate("PctNull", "tbl_DatedModel_2015_0702_0", "GM", "[GICS Sector] = " & VBA.Chr(34) & "Consumer Discretionary" & VBA.Chr(34))
'
'Debug.Print Now - x & "<- time diff1"


'much quicker way ........................................................start
x = Now


    'Excel is created once and passed to each calc
    'each query is done once and passed in to each calc
    Dim xl As Object
    Set xl = CreateObject("Excel.Application")
    
    'needs nulls/blanks .....................
    Dim vDataWithNulls
    vDataWithNulls = a2dvGetSubsetFromQuery("tbl_DatedModel_2015_0702_0", "GM", "[GICS Sector] = " & VBA.Chr(34) & "Consumer Discretionary" & VBA.Chr(34), sTest:="Numeric")
    
    Debug.Print DCalculate("Obs", av2dArray:=vDataWithNulls, oXl:=xl)
    Debug.Print DCalculate("PctNull", av2dArray:=vDataWithNulls, oXl:=xl)
    
    'needs to not have nulls/blanks ....................
    Dim vDataNoNulls
    vDataNoNulls = a2dvGetSubsetFromQuery("tbl_DatedModel_2015_0702_0", "GM", "[GM] IS NOT NULL AND [GICS Sector] = " & VBA.Chr(34) & "Consumer Discretionary" & VBA.Chr(34), sTest:="Numeric")
    
    Debug.Print DCalculate("Percentile", av2dArray:=vDataNoNulls, k:=0.25, oXl:=xl)
    Debug.Print DCalculate("Percentile", av2dArray:=vDataNoNulls, k:=0.5, oXl:=xl)
    Debug.Print DCalculate("Percentile", av2dArray:=vDataNoNulls, k:=0.75, oXl:=xl)
    
    Debug.Print DCalculate("Median", av2dArray:=vDataNoNulls, oXl:=xl)
    
    Debug.Print DCalculate("Kurtosis", av2dArray:=vDataNoNulls, oXl:=xl)
       
    Debug.Print DCalculate("Minimum", av2dArray:=vDataNoNulls, oXl:=xl)
    Debug.Print DCalculate("Maximum", av2dArray:=vDataNoNulls, oXl:=xl)
    
    Debug.Print DCalculate("IQR", av2dArray:=vDataNoNulls, oXl:=xl)
    
    Debug.Print DCalculate("Skewness", av2dArray:=vDataNoNulls, oXl:=xl)
    Debug.Print DCalculate("StDev", av2dArray:=vDataNoNulls, oXl:=xl)
    Debug.Print DCalculate("Mean", av2dArray:=vDataNoNulls, oXl:=xl)


Set xl = Nothing


Debug.Print Now - x & "<- time diff2"
End Sub
Public Function DCalculate(sCalc As String, Optional sTbl As String = "", Optional sMainFld As String = "", Optional sWhereClause As String = "", Optional ByVal av2dArray As Variant, Optional k As Double, Optional ByRef oXl As Object) As Variant
'http://www.mrexcel.com/forum/microsoft-access/237816-does-access-have-percentile-function-2.html#post4229429
'7/29/2015 this doesn't do true percentile calc, but it gets the value that is close to the 25th percentile... I tried:
'https://www.accessforums.net/queries/sql-aggregate-25-percentile-value-subsets-ms-53125.html
'it is close so I am moving on and will come back to this at some point.


'Use examples:
'see test() above.



If (Not VBA.IsMissing(av2dArray)) And (Not (VBA.IsArray(av2dArray) = True)) Then
    MsgBox "Array passed to DCalculate was not an array. Press OK to Stop and debug."
    Stop
End If


Dim dblData() As Double
Dim bXlWasCreated As Boolean
bXlWasCreated = False
If (Not IsMissing(oXl)) And (Not sMainFld = "") Then
    Set oXl = CreateObject("Excel.Application")
    bXlWasCreated = True
End If
Dim x As Integer


Dim aV() As Variant
Dim tmp
Dim lObsCnt As Long
Dim lNaCnt As Long
Dim i As Long
Dim vTmp As Variant
Dim lTtl As Long
Dim bDoCalc As Boolean


If (Not sTbl = "") And (Not sMainFld = "") And VBA.IsMissing(av2dArray) Then


    aV = a2dvGetSubsetFromQuery(sTbl, sMainFld, sWhereClause, "Numeric")
    If aV(0, 0) = "Not Numeric" Then
        MsgBox "Data returned by query was not numeric. Press OK to Stop and debug."
        Stop
    End If
Else
    aV = av2dArray
End If


If sCalc = "Percentile" Then
    DCalculate = oXl.WorksheetFunction.Percentile_Exc(aV, k)
ElseIf sCalc = "Median" Then
    DCalculate = oXl.WorksheetFunction.Median(aV)
ElseIf sCalc = "Kurtosis" Then
    DCalculate = oXl.WorksheetFunction.Kurt(aV)
ElseIf sCalc = "Minimum" Then
    DCalculate = oXl.WorksheetFunction.Min(aV)
ElseIf sCalc = "Maximum" Then
    DCalculate = oXl.WorksheetFunction.Max(aV)
ElseIf sCalc = "IQR" Then
    DCalculate = oXl.WorksheetFunction.Quartile_Exc(aV, 3) - oXl.WorksheetFunction.Quartile_Exc(aV, 1)
ElseIf sCalc = "Obs" Then
    lObsCnt = 0
    For Each tmp In aV
        If Not IsNull(tmp) Then
            lObsCnt = lObsCnt + 1
        End If
    Next
    DCalculate = lObsCnt
ElseIf sCalc = "PctNull" Then
    lNaCnt = 0
    lTtl = UBound(aV, 2) + 1
    For Each tmp In aV
        If IsNull(tmp) Then
            lNaCnt = lNaCnt + 1
        End If
    Next
    DCalculate = (lNaCnt / lTtl) * 100
ElseIf sCalc = "Skewness" Then
    DCalculate = oXl.WorksheetFunction.Skew(aV)
ElseIf sCalc = "StDev" Then
    DCalculate = oXl.WorksheetFunction.StDev_S(aV)
ElseIf sCalc = "Mean" Then
    DCalculate = oXl.WorksheetFunction.Average(aV)
Else
    MsgBox "sCalc parameter not recognized: " & sCalc & vbNewLine _
    & "Your choices are:" & vbNewLine _
    & "Percentile"
End If


cleanup:
If bXlWasCreated Then
    Set oXl = Nothing
End If


End Function
Function a2dvGetSubsetFromQuery(sTbl As String, sMainFld As String, sWhereClause As String, sTest As String) As Variant()
'sTest can be  "Numeric" or "None" ...will implement more as needed
Dim iFieldType As Integer
Dim rst As DAO.Recordset
Dim db As Database
Set db = CurrentDb
Dim sMainFldFull As String
Dim sSubSetFldFull As String
Dim sSql As String


sMainFldFull = "[" & sMainFld & "]"
sSubSetFldFull = ""
sSql = ""


sSql = "SELECT " & sMainFldFull & " FROM " & sTbl
If Len(sWhereClause) > 0 Then
    sSql = sSql & " WHERE " & sWhereClause
End If


Set rst = db.OpenRecordset(sSql, dbOpenSnapshot)


'make sure the data is the right type


iFieldType = rst(sMainFld).Type


If sTest = "Numeric" Then
    If iFieldType = dbByte Or _
        iFieldType = dbInteger Or _
        iFieldType = dbLong Or _
        iFieldType = dbCurrency Or _
        iFieldType = dbSingle Or _
        iFieldType = dbDouble _
        Then
        rst.MoveLast
        rst.MoveFirst
        
        a2dvGetSubsetFromQuery = rst.GetRows(rst.RecordCount)
        
    Else
        Dim aV(0 To 1, 0 To 1) As Variant
        aV(0, 0) = "Not Numeric"
        a2dvGetSubsetFromQuery = aV
        
    End If
ElseIf sTest = "None" Then
    'don't do any testing
    rst.MoveLast
    rst.MoveFirst
    
    a2dvGetSubsetFromQuery = rst.GetRows(rst.RecordCount)
Else
    MsgBox "Test type (sTest) can only be 'None' or 'Numeric'. It was: " & sTest
    Stop
End If


cleanup:
rst.Close
Set rst = Nothing
End Function