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 = DCount(InputColumn, InputTable, "[" &
InputColumn & "] is not NUll and " & AdditionalCriteria)
Else
Let intCount = DCount(InputColumn, InputTable, "[" &
InputColumn & "] is not NUll")
End If
If intCount = 0 Then GoTo NoRecords
Let strfile = Application.CurrentProject.Path & "\Temp" &
Format(Now(), "MMM-DD-YYYY") & ".xls"
Rem Save the specified column to Excel
Set dbsCurrent = 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 = "SELECT [" & InputColumn & "] FROM [" &
InputTable & "]"
If Len(Trim(AdditionalCriteria)) > 0 Then
Let strSQL = strSQL & " WHERE [" & InputColumn & "] is not
NUll and " & AdditionalCriteria
Else
Let strSQL = strSQL & " WHERE [" & InputColumn & "] is not
NUll"
End If
Set qdfNew = .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 = GetObject(, "Excel.Application") ' reference an
existing application instance
If objExcel Is Nothing Then ' no existing application is running
Set objExcel = New Excel.Application ' create a new
application instance
Let blnExcelAlreadyOpen = False
Else
Let blnExcelAlreadyOpen = 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 = objExcel.Workbooks.Open(strfile, , False)
Rem Put Formulas in Excel for centile
With objWorkBook.Worksheets(1)
Let .Range("B1").Value = "Percentile"
Let .Range("C1").Value = "Value"
For intCentile = 1 To 99
Let .Range("B" & intCentile + 1).Value = intCentile
Let .Range("C" & intCentile + 1).Formula =
"=PERCENTILE(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 = Nothing
If Not (blnExcelAlreadyOpen) Then
objExcel.Application.Quit
End If
Set objExcel = Nothing
Rem if the table already exists, delete it
dbsCurrent.TableDefs.Delete OutputTable
dbsCurrent.TableDefs.Refresh
Set dbsCurrent = 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 = 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 = 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 = 1 To 99
DoCmd.RunSQL "INSERT INTO [" & OutputTable & "]([Percentile])
VALUES (" & intCentile & ")"
Next intCentile
Exit Sub
ErrorHandler:
If Err.Number = 429 Then 'Excel is not already open, this is okay
Err.Clear
Resume Next
ElseIf Err.Number = 91 Then 'Object Variable Not set, this is okay
Err.Clear
Resume Next
ElseIf Err.Number = 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
