Insert Subtotals Within Range Using VBA

[Purdue02]

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

 

[Purdue02]

I got it to work using the following code.

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