Access Sub-Total Function Code 4 u

[rich.barry]

A while back I wrote a procedure to carry out sub totals within Access similar to the function available in Excel.
I might as well share it here, and others can hack it around to fit their own needs.

Here's an example of the sort of thing I'm using it for.

A production system writes time stamped machinery setting data to a table at regular intervals. I then want a list of start and stop time of the production runs, a run being defined as each time they change product thickness.

First I'm going to make a query (qryPressRuns) to get the relevant data from the table
SELECT MW_Vis_Data.VisDateTime AS Time1, MW_Vis_Data.VisDateTime AS Time2, MW_Vis_Data.Thickness FROM MW_Vis_Data;

in this case I've extracted the time stamp twice in the query, as I want a start time and a stop time for the runs

Next I call my sub total function with the following code

Sub test()
SubTotals "qryPressRuns", "TableOut", sbQuery, "Thickness", "Time1/Min,Time2/Max,Thickness/Min", sbDisplaySubTotals
End Sub

Arguments of the sub total function are:

Data source table/query/SQL statement
Data source type = sbTable, sbQuery or sbSQL
Output table name
Field name which change in is going to trigger sub total
List of Field names being subtotaled and type of sub total e.g. "Time1/Min,Time2/Max"
sbDisplaySubTotals or sbDisplayAll depending on whether you want the data as well as the sub total

At present, Max,Min,Count,Sum and Average are supported in the code, but you can program any others you want to.
In the output table, an IndexNumber and SubTotal fields are generated. Sorting by the IndexNumber when you are displaying data as well as sub totals will put the sub total at the bottom of each data segment, whilst sorting by the subtotal will list all the data, then all the sub totals

Function code is below.

Hope this helps someone.

Function SubTotals(sbDataSource As String, sbSourceType As Integer, sbOutputTable As String, sbChangeIn As String, sbFieldData As String, sbDisplay As Integer) As String
'Syntax example
'SubTotals "qrylogsuppliersummary", "TableOut", sbQuery, "supplierid", "Logcount/Sum,DocketNumber/Count,NonConformances/Sum,avgofHitVelocity/Average", sbDisplayAll

Dim SourceData As New ADODB.Recordset
Dim Result As New ADODB.Recordset
Dim strSQL As String
Dim strRunSQL As String
Dim ChangeInCurrent As String
Dim commapos As Integer
Dim fieldx(100, 2) As String    '1=Field to Sub Total, 2=Type of Sub Total
Dim totals(100) As Double
Dim min(100) As Variant
Dim max(100) As Variant
Dim WriteFlag As Boolean
Dim CountofRecords(100) As Long
Dim pos As Integer
Dim v As Variant
Dim X As Integer
Dim c As Integer
Dim IndexNumber As Long

'Delimit the data in sbFieldData. X is the number of fields being sub totalled
X = 1
'If Right(sbFieldData, 1) <> "," Then sbFieldData = sbFieldData & ","
For pos = 1 To Len(sbFieldData)
    If Mid(sbFieldData, pos, 1) <> "," Then
        fieldx(X, 1) = fieldx(X, 1) & Mid(sbFieldData, pos, 1)
    Else
        If fieldx(X, 1) <> "" Then X = X + 1
    End If
Next pos

For c = 1 To X
    fieldx(c, 2) = Mid(fieldx(c, 1), InStr(1, fieldx(c, 1), "/") + 1)
    fieldx(c, 1) = Left(fieldx(c, 1), InStr(1, fieldx(c, 1), "/") - 1)
Next c

'Open the source data
Select Case sbSourceType
Case 1, 2
    strSQL = "SELECT 999.9 AS IndexNumber, * FROM " & sbDataSource
Case 3
    strSQL = sbDataSource
End Select

'Create the result table. The WHERE FALSE criteria creates the table structure without data.
pos = InStr(1, strSQL, "FROM")
strRunSQL = Left(strSQL, pos - 1) & "INTO " & sbOutputTable & " " & Mid(strSQL, pos)
If sbDisplay = sbDisplaySubTotals Then strRunSQL = strRunSQL & " WHERE False"

DoCmd.SetWarnings False
DoCmd.RunSQL strRunSQL
DoCmd.SetWarnings True

With DBEngine(0)(0).TableDefs(sbOutputTable)
  .Fields.Append .CreateField("SubTotals", dbText, 100)
End With

'SubTotal the data
SourceData.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockPessimistic
Result.Open "SELECT * FROM " & sbOutputTable, CurrentProject.Connection, adOpenKeyset, adLockPessimistic
    
IndexNumber = 1

'If displaying all data, then add an index number for subsequent sorting
If sbDisplay = sbDisplayAll Then
    With Result
        .MoveFirst
        Do While Not .EOF
            !IndexNumber = IndexNumber
            .Update
            .MoveNext
            IndexNumber = IndexNumber + 1
        Loop
    End With
End If

With SourceData
    .MoveFirst
    IndexNumber = 0
    Do
        If .AbsolutePosition <> adPosEOF Then
            'Read initial value of field being monitored for change
            If .AbsolutePosition = 1 Then ChangeInCurrent = Nz(.Fields(sbChangeIn), 0)
            If .Fields(sbChangeIn) <> ChangeInCurrent Then
                WriteFlag = True
            End If
        Else
            WriteFlag = True
        End If
        
        If WriteFlag = True Then
            'write new subtotal
            Result.AddNew
            Result.Fields(sbChangeIn) = ChangeInCurrent
            Result.Fields("SubTotals") = ChangeInCurrent & " Sub-Total"
            Result!IndexNumber = IndexNumber + 0.1
            If .AbsolutePosition <> adPosEOF Then ChangeInCurrent = .Fields(sbChangeIn)
            
            For c = 1 To X
                Select Case fieldx(c, 2)
                Case "Sum"
                        v = totals(c)
                Case "Average"
                        If CountofRecords(c) > 0 Then
                            v = totals(c) / CountofRecords(c)
                        Else
                            v = 0
                        End If
                Case "Count"
                        v = CountofRecords(c)
                Case "Max"
                        v = max(c)
                Case "Min"
                        v = min(c)
                End Select
                Result.Fields(fieldx(c, 1)) = v
            Next c
            
            Result.Update
            Erase totals()
            Erase CountofRecords
            Erase min()
            Erase max()
            WriteFlag = False
        End If
        
        If .AbsolutePosition = adPosEOF Then Exit Do
        
        For c = 1 To X
            totals(c) = totals(c) + Val(Nz(.Fields(fieldx(c, 1)), 0))
            'Don't index the record count for a null field for average calculations
            If fieldx(c, 2) <> "Average" Or (fieldx(c, 2) = "Average" And Not IsNull(.Fields(fieldx(c, 1)))) Then CountofRecords(c) = CountofRecords(c) + 1
            If IsNull(max(c)) Or max(c) = "" Or .Fields(fieldx(c, 1)) > max(c) Then max(c) = .Fields(fieldx(c, 1))
            If IsNull(min(c)) Or min(c) = "" Or .Fields(fieldx(c, 1)) < min(c) Then min(c) = .Fields(fieldx(c, 1))
        Next c
        IndexNumber = IndexNumber + 1
    .MoveNext
    Loop
    .Close
End With

Set SourceData = Nothing

Result.Close
Set Result = Nothing

SubTotals = sbOutputTable

End Function