Insert Subtotals Within Range Using VBA

[Purdue2479]

I am using the below code to insert a recordset into Access from Excel, insert total rows at each change in column A, and apply greenbar formatting to the specified range of data. What I want to do is to insert sum calculations into the subtotal rows, but do not know how to dynamically sum each set of data at each change in customer (col A). Example code would be appreciated. Thanks.

Option  Compare  Database 
Option Explicit 
 
Dim oBook As Excel.Workbook 
Dim oSheet As Excel.Worksheet 
Dim oApp As New Excel.Application 
 
Dim lRow As Long 
Dim lastrow As Long 
 
Public strCriteria As String 
Public strStore_Type As String 
Public varItem As Variant 
Public Progress As Variant 
 
Sub Export_Qry() 
     
    Dim db As DAO.Database 
    Dim rs As DAO.Recordset 
     
    Progress = SysCmd(acSysCmdInitMeter, "Exporting Data to Excel...", 21) 
     
    Set db = CurrentDb 
    Set rs = db.OpenRecordset("qryTotal_Share_SKU-Final", dbOpenSnapshot) 
     
    Set oBook = oApp.Workbooks.Open("U:\Desktop\Total Share by SKU_Mail-Retail.xls") 
    Set oSheet = oBook.Worksheets(2) 
     
     'Add the data starting at cell A5
    oSheet.Range("A5").CopyFromRecordset rs 
     
    Progress = SysCmd(acSysCmdInitMeter, "Exporting Data to Excel...", 21) 
    Progress = SysCmd(acSysCmdUpdateMeter, 21) 
     
    Progress = SysCmd(acSysCmdClearStatus) 
    Progress = SysCmd(acSysCmdRemoveMeter) 
     
    Call ApplyGreenBarToSelection 
    Call Add_Totals 
     
    oBook.Worksheets(2).Activate 
     
    oApp.DisplayAlerts = False 
     
    oBook. SaveAs "U:\Desktop\Total_Share_SKU.xls" 
     
    oApp.DisplayAlerts = True 
     
     MsgBox "Export Complete!" 
     
    oBook.Close 
    oApp.Quit 
     
     'Close Recordset and clear  objects
    rs.Close 
    Set oBook = Nothing 
    Set oSheet = Nothing 
    Set oApp = Nothing 
     
     
End Sub 
 
Sub Add_Totals() 
     
    Dim i As Integer 
     
    oSheet.Select 
     
    For lRow = oSheet.Cells(oSheet.Rows.Count, "A").End(xlUp).Row To 6  Step -1 
         
        If oSheet.Cells(lRow, "A") <> oSheet.Cells(lRow - 1, "A") Then 
             
            oSheet.Rows(lRow).EntireRow.Insert 
            oSheet.Range("A" & lRow - 1).Select 
            oApp.Selection.Copy 
            oSheet.Range("A" & lRow).Select 
            oApp.ActiveSheet.Paste 
            oSheet.Range("B" & lRow).Select 
            oApp.ActiveCell.FormulaR1C1 = "Totals" 
            oApp.ActiveCell.Font.FontStyle = "Bold" 
            oApp.ActiveCell.Font.ColorIndex = 2 
            oApp.ActiveCell.Interior.ColorIndex = 50 
            oApp.ActiveCell.Interior.Pattern = xlSolid 
            oApp.Application.CutCopyMode = False 
             
        End If 
         
    Next lRow 
     
End Sub 
 
Sub ApplyGreenBarToSelection() 
     
    Dim c As Range 
    Dim lRow 
    Dim LastColumn As Integer 
    Dim ColumnLetter As String 
     
    lastrow = oSheet.Cells(oSheet.Rows.Count, "B").End(xlUp).Row 
     
    With oApp.Worksheets(2) 
        On  Error Resume Next 
        LastColumn = oSheet.Cells. Find("*", oSheet.Cells(1), xlFormulas, _ 
        xlWhole, xlByColumns, xlPrevious).Column 
        If Err <> 0 Then LastColumn = 0 
    End With 
     
    For Each c In oSheet.Range("A5:" & ExcelCol(LastColumn) & lastrow) 
         
        If c.Offset(-1, 0).Interior.ColorIndex = xlNone Then 
             
            oSheet.Range("A" & c.Row & ":" & ExcelCol(LastColumn) & c.Row).Interior.ColorIndex = 35 
             
        End If 
         
        If c.Offset(-1, 0).Interior.ColorIndex = 35 Then 
             
            oSheet.Range("A" & c.Row & ":" & ExcelCol(LastColumn) & c.Row).Interior.ColorIndex = xlNone 
             
        End If 
         
    Next c 
     
     
End Sub 
 
Public  Function ExcelCol(intColNum As Integer) As String 
    Dim iLastChar As Integer 
    Dim iFirstChar As Integer 
     
    iFirstChar = (intColNum - 1) \ 26 
    iLastChar = (intColNum - 1) Mod 26 
    If iFirstChar > 0 Then 
        ExcelCol = Chr(Asc("A") + iFirstChar - 1) & Chr(Asc("A") + iLastChar) 
    Else 
        ExcelCol = Chr(Asc("A") + iLastChar) 
    End If 
     
     
     
End Function

 

[Purdue2479]

Below is the solution I came up with.

Option Compare Database
Option Explicit

Dim oBook As Excel.Workbook
Dim oSheet As Excel.Worksheet
Dim oApp As New Excel.Application

Dim lRow As Long
Dim lastrow As Long
    
Dim sParts() As String
    
Public strCriteria As String
Public strStore_Type As String
Public varItem As Variant
Public Progress As Variant

Sub Export_Qry()

    Dim db As DAO.Database
    Dim rs As DAO.Recordset
   
    Progress = SysCmd(acSysCmdInitMeter, "Exporting Data to Excel...", 21)
    
    Set db = CurrentDb
    Set rs = db.OpenRecordset("qryTotal_Share_SKU-Final", dbOpenSnapshot)
    
    Set oBook = oApp.Workbooks.Open("U:\Desktop\Total Share by SKU_Mail-Retail.xls")
    Set oSheet = oBook.Worksheets(2)
            
    oSheet.Range("A5").CopyFromRecordset rs
         
    Progress = SysCmd(acSysCmdUpdateMeter, 7)
        
    'Call Format_WorkSheets
    
    Progress = SysCmd(acSysCmdInitMeter, "Formatting Worksheet...", 21)
    Progress = SysCmd(acSysCmdUpdateMeter, 7)
    
    Call Add_Totals
            
    Progress = SysCmd(acSysCmdUpdateMeter, 14)
        
    Progress = SysCmd(acSysCmdInitMeter, "Adding Totals...", 21)
    Progress = SysCmd(acSysCmdUpdateMeter, 14)
    
    Call ApplyGreenBarToSelection
    
    Progress = SysCmd(acSysCmdUpdateMeter, 21)

    Progress = SysCmd(acSysCmdClearStatus)
    Progress = SysCmd(acSysCmdRemoveMeter)
    
    oBook.Worksheets(2).Activate
    
    oApp.DisplayAlerts = False
    
    oBook.SaveAs "U:\Desktop\Total_Share_SKU.xls"
    
    oApp.DisplayAlerts = True
        
    MsgBox "Export Complete!"
        
    oBook.Close
    oApp.Quit
    
rs.Close
Set oBook = Nothing
Set oSheet = Nothing
Set oApp = Nothing


End Sub

Sub Add_Totals()

    Dim i As Integer
    Dim col As Integer
            
    oSheet.Select
        
    For lRow = oSheet.Cells(oSheet.Rows.Count, "A").End(xlDown).Row To 6 Step -1
    
        If oSheet.Cells(lRow, "A") <> oSheet.Cells(lRow - 1, "A") Then
    
            oSheet.Rows(lRow).EntireRow.Insert
            oSheet.Range("A" & lRow - 1).Select
            oApp.Selection.Copy
            oSheet.Range("A" & lRow).Select
            oApp.ActiveSheet.Paste
            oSheet.Range("B" & lRow).Select
            oApp.ActiveCell.FormulaR1C1 = "Total"
            oApp.ActiveCell.Font.FontStyle = "Bold"
            oApp.ActiveCell.Font.ColorIndex = 2
            oApp.ActiveCell.Interior.ColorIndex = 50
            oApp.ActiveCell.Interior.Pattern = xlSolid
            oApp.Application.CutCopyMode = False
        
        End If
    
    Next lRow
    
    Call where_is("Total")
    
    lRow = oSheet.Cells(oSheet.Rows.Count, "A").End(xlUp).Row
    
    oSheet.Range("A" & lRow + 1).Select
    oApp.ActiveCell.FormulaR1C1 = "Total"
    oApp.ActiveCell.Font.FontStyle = "Bold"
    oApp.ActiveCell.Font.ColorIndex = 2
    oApp.ActiveCell.Interior.ColorIndex = 50
    oApp.ActiveCell.Interior.Pattern = xlSolid
   
    For i = 5 To oSheet.UsedRange.Rows.Count
        
        If oSheet.Cells(i, 2).Value = "Total" Then
                           
            For col = 5 To oSheet.UsedRange.Columns.Count
                
                If sParts(0) = 5 Then
                
                    oSheet.Cells(i, col).Formula = "=Sum(A5:A500, A" & i & "," & _
                        ExcelCol(col) & sParts(0) & ":" & ExcelCol(col) & i - 1 & ")"
                
                Else
                    
                    oSheet.Cells(i, col).Formula = "=Sum(A5:A500, A" & i & "," & _
                        ExcelCol(col) & sParts(0) + 1 & ":" & ExcelCol(col) & i - 1 & ")"
                                    
                End If
                                    
                    oSheet.Cells(lRow + 1, col).Formula = "=SumIf(B5:B500," & Chr(34) & "Total" & Chr(34) & "," & _
                        ExcelCol(col) & "5:" & ExcelCol(col) & lRow & ")"
                   
                   'oSheet.Cells(i, col).Value = oApp.WorksheetFunction.SumIf(oSheet.Range("A5:A500"), oSheet.Range("A" & lRow), oSheet.Range(ExcelCol(i) & prevlrow & ":" & ExcelCol(i) & lRow - 1))
            Next col
              
        Call DeleteArrayElement(InputArray:=sParts, ElementNumber:=0, ResizeDynamic:=True)
        
        End If
        
    Next i
 
End Sub

Sub ApplyGreenBarToSelection()
    
   Dim c As Range
   Dim lRow
   Dim LastColumn As Integer
   Dim ColumnLetter As String
   
   lastrow = oSheet.Cells(oSheet.Rows.Count, "A").End(xlUp).Row
   

    With oApp.Worksheets(2)
        On Error Resume Next
        LastColumn = oSheet.Cells.Find("*", oSheet.Cells(1), xlFormulas, _
        xlWhole, xlByColumns, xlPrevious).Column
        If Err <> 0 Then LastColumn = 0
    End With
         
'    oSheet.Range("A5:" & ExcelCol(LastColumn) & lastrow).Select
'    oApp.Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
'        "=MOD(ROW(),2)=0"
'    oApp.Selection.FormatConditions(1).Interior.ColorIndex = 35
         
    For Each c In oSheet.Range("A5:" & ExcelCol(LastColumn) & lastrow)

        If c.Offset(-1, 0).Interior.ColorIndex = xlNone Then

                oSheet.Range("A" & c.Row & ":" & ExcelCol(LastColumn) & c.Row).Interior.ColorIndex = 35
       
        Else 'c.Offset(-1, 0).Interior.ColorIndex = 35

                oSheet.Range("A" & c.Row & ":" & ExcelCol(LastColumn) & c.Row).Interior.ColorIndex = xlNone
        
        End If
        
        If oSheet.Cells(c.Row, 2).Value = "Total" Then
                
                oSheet.Range("B" & c.Row & ":" & ExcelCol(LastColumn) & c.Row).Interior.ColorIndex = 50
                oSheet.Range("B" & c.Row & ":" & ExcelCol(LastColumn) & c.Row).Font.ColorIndex = 2
                oSheet.Range("B" & c.Row & ":" & ExcelCol(LastColumn) & c.Row).Font.FontStyle = "Bold"
                
        ElseIf oSheet.Cells(c.Row, 1).Value = "Total" Then
        
                oSheet.Range("A" & c.Row & ":" & ExcelCol(LastColumn) & c.Row).Interior.ColorIndex = 50
                oSheet.Range("A" & c.Row & ":" & ExcelCol(LastColumn) & c.Row).Font.ColorIndex = 2
                oSheet.Range("A" & c.Row & ":" & ExcelCol(LastColumn) & c.Row).Font.FontStyle = "Bold"
        End If

    Next c


End Sub

Public Function ExcelCol(intColNum As Integer) As String
    
    Dim iLastChar As Integer
    Dim iFirstChar As Integer
    
    iFirstChar = (intColNum - 1) \ 26
    iLastChar = (intColNum - 1) Mod 26
    If iFirstChar > 0 Then
        ExcelCol = Chr(Asc("A") + iFirstChar - 1) & Chr(Asc("A") + iLastChar)
    Else
        ExcelCol = Chr(Asc("A") + iLastChar)
    End If
   
End Function

Public Function DeleteArrayElement(InputArray As Variant, ElementNumber As Long, _
    Optional ResizeDynamic As Boolean = False) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DeleteArrayElement
' This function deletes an element from InputArray, and shifts elements that are to the
' right of the deleted element to the left. If InputArray is a dynamic array, and the
' ResizeDynamic parameter is True, the array will be resized one element smaller. Otherwise,
' the right-most entry in the array is set to the default value appropriate to the data
' type of the array (0, vbNullString, Empty, or Nothing). If the array is an array of Variant
' types, the default data type is the data type of the last element in the array.
' The function returns True if the elememt was successfully deleted, or False if an error
' occurrred. This procedure works only on single-dimensional
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim Ndx As Long
Dim VType As VbVarType

''''''''''''''''''''''''''''''''
' Set the default result
''''''''''''''''''''''''''''''''
DeleteArrayElement = False

''''''''''''''''''''''''''''''''
' Ensure InputArray is an array.
''''''''''''''''''''''''''''''''
If IsArray(InputArray) = False Then
    Exit Function
End If

''''''''''''''''''''''''''''''''''''''''''''''
' Ensure we have a valid ElementNumber
''''''''''''''''''''''''''''''''''''''''''''''
If (ElementNumber < LBound(InputArray)) Or (ElementNumber > UBound(InputArray)) Then
    Exit Function
End If

''''''''''''''''''''''''''''''''''''''''''''''
' Get the variable data type of the element
' we're deleting.
''''''''''''''''''''''''''''''''''''''''''''''
VType = VarType(InputArray(UBound(InputArray)))
If VType >= vbArray Then
    VType = VType - vbArray
End If

''''''''''''''''''''''''''''''''''''''''''''''
' Shift everything to the left
''''''''''''''''''''''''''''''''''''''''''''''
For Ndx = ElementNumber To UBound(InputArray) - 1
    InputArray(Ndx) = InputArray(Ndx + 1)
Next Ndx

'''''''''''''''''''''''''''''
' Set the last element of the
' InputArray to the proper
' default value.
'''''''''''''''''''''''''''''
Select Case VType
    Case vbByte, vbInteger, vbLong, vbSingle, vbDouble, vbDate, vbCurrency, vbDecimal
        InputArray(UBound(InputArray)) = 0
    Case vbString
        InputArray(UBound(InputArray)) = vbNullString
    Case vbArray, vbVariant, vbEmpty, vbError, vbNull, vbUserDefinedType
        InputArray(UBound(InputArray)) = Empty
    Case vbBoolean
        InputArray(UBound(InputArray)) = False
    Case vbObject
        Set InputArray(UBound(InputArray)) = Nothing
    Case Else
        InputArray(UBound(InputArray)) = 0
End Select

DeleteArrayElement = True

End Function

Function where_is(s As String) As String

Dim N As Long
Dim i As Integer

    where_is = 5
    
    N = oSheet.Cells(oSheet.Rows.Count, "A").End(xlUp).Row
    
    For i = 1 To N
        
        If oSheet.Cells(i, "B").Value = s Then
            where_is = where_is & "," & i
        End If
        
    Next
    
    If where_is = "" Then Exit Function
        
    'where_is = Right(where_is, Len(where_is) - 1)
    
    sParts = Split(where_is, ",")
          
End Function