How can I use VBA to SubTotal

[TraciAnn via OfficeKB.com]

I export data from Access to Excel.

I need the data to "automatically" subtotal so the user isn't required to.

Apparently Access cannot export to an Excel template file so the following is
what I currently do (followed by what I still need).

Currently:
1. The WorkBook
FileName: "CallDetail.xls"
WorkSheet: "Weekly Calls"
Named Range: "Weekly Calls" ($B$1:$C$2) the range is dynamic based on
the size of the incoming data.
Row 1 is the header row with formatting in place

2. Access exports the data using:
stDocName = "CallDetail.xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9,
"qryCallDetail", stDocName, , "WeeklyCalls"
Application.FollowHyperlink stDocName, , True

3. The data is inserted into CallDetail.xls beginning in the first cell of
the named range

4. The range "WeeklyCalls" is adjusted to accomodate all imported data.

What I need help with:
1. Return the file "CallDetail.xls" to its original (pre-export) condition.
2. Name the new file (with the exported data) "CallDetail mmddyy.xls" (where
mmddyy is Date())
3. Subtotal data for each break in Column A (Technician), Sum Column D
(Duration)

Thanks for your help!

 

[arjen van der wal]

Hi,

Here's one way you can try. It requires that you add a reference to the
Excel in your project (Tools > References > Microsoft Excel 8.0 Object
Library).
After the query has been exported to Excel, it opens it (instead of
being opened by Application.Hyperlink). A date variable is created for the
Save As and then it's sorted & sub-totaled & closed.
The original file is then re-opened and the query results deleted.
Hopefully this works for you, or at least helps.


Sub Ex1()

Dim stDocName As String
stDocName = "C:\VB 2008\CallDetail.xls"

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel8, _
"qryCallDetails", stDocName, , "WeeklyCalls"

Dim xl As Excel.Application
Dim xlwb As Excel.Workbook

Set xl = New Excel.Application
Set xlwb = xl.Workbooks.Open(stDocName)

xl.Visible = True

Dim dtSave As String
dtSave = Format(Now(), "mmddyy")
xlwb.SaveAs ("C:\VB 2008\CallDetail" & dtSave & ".xls")

Dim WeeklyCalls As Range
Set WeeklyCalls = xlwb.Sheets("WeeklyCalls").Range("A1").CurrentRegion

With xlwb.Sheets("WeeklyCalls").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A:A"), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.SetRange WeeklyCalls
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With

With xlwb.Sheets("WeeklyCalls").Range("WeeklyCalls")
.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(4), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End With

xlwb.Close SaveChanges:=True

Set xlwb = xl.Workbooks.Open(stDocName)
xl.DisplayAlerts = False
xlwb.Sheets("WeeklyCalls").Delete
xl.DisplayAlerts = True
xlwb.Close SaveChanges:=True

xl.Quit

Set xl = Nothing

End Sub