Access Sub-Total Function Code 4 u (1 Viewer)

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