How do I create deciles in Microsoft Access?

philt <philt@discussions.microsoft.com> wrote:

> How do I create deciles in Microsoft Access?


Check out

  http://www.mvps.org/access/queries/qry0019.htm


HTH
Matthias Kl�y
-- 
www.kcc.ch

On Nov 26, 1:29 pm, Matthias Klaey <m...@hotmail.com> wrote:
> philt <ph...@discussions.microsoft.com> wrote:
> > How do I create deciles in Microsoft Access?
>
> Check out
>
>  http://www.mvps.org/access/queries/qry0019.htm
>
> HTH
> Matthias Kl=E4y
> --www.kcc.ch

An alternate approach is to use Excel from Access as in the following:
Public Sub CreateCentileDistribution(InputTable As String, InputColumn
As String, AdditionalCriteria As String, OutputTable As String)
    Rem Opens an excel workbook, and transfers Input Column, then
pastes in Centile functions, and inputs data to Access

    Rem Early Binding has to have reference set to Excel object
library
    Rem Also need reference to DAO
    Dim objExcel As Excel.Application
    Dim objWorkBook As Excel.Workbook
    Dim blnExcelAlreadyOpen As Boolean
    Dim dbsCurrent As DAO.Database
    Dim qdfNew As QueryDef
    Dim tdfNew As TableDef
    Dim strSQL As String
    Dim intCentile As Integer
    Dim intCount As Integer
    Dim strfile As String

    On Error GoTo ErrorHandler

    DoCmd.SetWarnings False

    Rem See if there are any records to calculate a distribution based
on
    If Len(Trim(AdditionalCriteria)) > 0 Then
        Let intCount =3D DCount(InputColumn, InputTable, "[" &
InputColumn & "] is not NUll and " & AdditionalCriteria)
    Else
        Let intCount =3D DCount(InputColumn, InputTable, "[" &
InputColumn & "] is not NUll")
    End If
    If intCount =3D 0 Then GoTo NoRecords

    Let strfile =3D Application.CurrentProject.Path & "\Temp" &
Format(Now(), "MMM-DD-YYYY") & ".xls"

    Rem Save the specified column to Excel
    Set dbsCurrent =3D CurrentDb
    With dbsCurrent
        Rem Delete Temp query if it exists
        .QueryDefs.Delete "Temp"
        Rem Create a temporary Query with just the specified column
        Let strSQL =3D "SELECT [" & InputColumn & "] FROM [" &
InputTable & "]"
        If Len(Trim(AdditionalCriteria)) > 0 Then
            Let strSQL =3D strSQL & " WHERE [" & InputColumn & "] is not
NUll and " & AdditionalCriteria
        Else
            Let strSQL =3D strSQL & " WHERE [" & InputColumn & "] is not
NUll"
        End If
        Set qdfNew =3D .CreateQueryDef("Temp", strSQL)
        Rem Export the query to Excel
        DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9,
"Temp", strfile, True
        Rem Delete the temporary query
        .QueryDefs.Delete qdfNew.Name
    End With

    Rem Open the Excel File and calculate the Centile distribution
    Set objExcel =3D GetObject(, "Excel.Application")  ' reference an
existing application instance
    If objExcel Is Nothing Then ' no existing application is running
        Set objExcel =3D New Excel.Application ' create a new
application instance
        Let blnExcelAlreadyOpen =3D False
    Else
        Let blnExcelAlreadyOpen =3D True
        Rem Activate excel, then hit enter, in case editing a cell
        AppActivate "Microsoft Excel"
        objExcel.Application.SendKeys "{ENTER}"
    End If

    Rem Open the Excel Workbook just created
    Set objWorkBook =3D objExcel.Workbooks.Open(strfile, , False)

    Rem Put Formulas in Excel for centile
    With objWorkBook.Worksheets(1)
        Let .Range("B1").Value =3D "Percentile"
        Let .Range("C1").Value =3D "Value"
        For intCentile =3D 1 To 99
            Let .Range("B" & intCentile + 1).Value =3D intCentile
            Let .Range("C" & intCentile + 1).Formula =3D
"=3DPERCENTILE(A2:A" & intCount + 1 & ",B" & intCentile + 1 & "/100)"
        Next intCentile
    End With

    Rem Close the workbook and excel
    objWorkBook.Save
    objWorkBook.Close False
    Set objWorkBook =3D Nothing
    If Not (blnExcelAlreadyOpen) Then
        objExcel.Application.Quit
    End If
    Set objExcel =3D Nothing

    Rem if the table already exists, delete it
    dbsCurrent.TableDefs.Delete OutputTable
    dbsCurrent.TableDefs.Refresh
    Set dbsCurrent =3D Nothing

    Rem Import the excel file to Access
    DoCmd.TransferSpreadsheet acImport, 8, OutputTable, strfile, True,
"B1:C100"

    Rem Delete the excel file
    Kill strfile

    Exit Sub

NoRecords:
    Rem if there was no cases in the recordset, then change table to
be a numeric
    Set dbsCurrent =3D CurrentDb

    Rem if the table already exists, delete it
    dbsCurrent.TableDefs.Delete OutputTable
    dbsCurrent.TableDefs.Refresh

    Rem Create a new TableDef object for the Data Dictionary Tables
Table
    Set tdfNew =3D dbsCurrent.CreateTableDef(OutputTable)

    Rem Add fields to table definition
    With tdfNew
        Rem Create fields and append them to the new TableDef
        Rem object. This must be done before appending the
        Rem TableDef object to the TableDefs collection
        .Fields.Append .CreateField("Percentile", dbSingle)
        .Fields.Append .CreateField("Value", dbDouble)
    End With

    Rem Append the new TableDef object to the database.
    dbsCurrent.TableDefs.Append tdfNew

    Rem Add the percentiles with no values to table
    For intCentile =3D 1 To 99
        DoCmd.RunSQL "INSERT INTO [" & OutputTable & "]([Percentile])
VALUES (" & intCentile & ")"
    Next intCentile
    Exit Sub


ErrorHandler:
    If Err.Number =3D 429 Then 'Excel is not already open, this is okay
        Err.Clear
        Resume Next
    ElseIf Err.Number =3D 91 Then 'Object Variable Not set, this is okay
        Err.Clear
        Resume Next
    ElseIf Err.Number =3D 3265 Then 'Tried to delete a table or query
that doesn't exist, this is ok
        Err.Clear
        Resume Next
    Else
        MsgBox "An unexpected error occurred." & vbCrLf & _
          "Please note the error, and the circumstances" _
          & vbCrLf & "Error #" & Err.Number & " : " & Err.Description,
vbCritical, _
          "Unexepcted Error"
    End If
End Sub