What's the method of bolding Excel subtotals from Access vba? - excel

Question

I have an Access 2010 application where I run a SQL query and output the results to Excel. I'm using the Excel subtotal command to create subtotals. That works fine, but on the total rows only the text ("XXX Count") is bold and the values are not bold. Our client would like the entire row bold. I've tried a couple ways without success. How do I do the entire row in the subtotals?
So here is what I currently have:
This is correct except I need all of row 5, 8, 16, and 17 bold like this:
Here is my code to create the Excel file from Access (this all works except for the bold issues):
Public Sub ExportToExcel(query)
Dim appXL As Object
Dim wbk As Object
Dim wksNew As Object
Set appXL = CreateObject("Excel.Application")
Set wbk = appXL.Workbooks.Add
Set wksNew = wbk.Worksheets("Sheet1")
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set appXL = CreateObject("Excel.Application")
appXL.Visible = True
Set wbk = appXL.Workbooks.Add
Set wksNew = wbk.Worksheets(1)
Set cn = CurrentProject.AccessConnection
Set rs = New ADODB.Recordset
With rs
Set .ActiveConnection = cn
.Source = query
.Open
End With
With rs
'Put recordset into new wks
wksNew.Cells(2, 1).CopyFromRecordset rs
'And add headers
Dim i As Long
For i = 0 To .Fields.Count - 1
wksNew.Cells(1, i + 1).Value = .Fields(i).Name
wksNew.Cells(1, i + 1).Font.Bold = True
wksNew.Cells(1, i + 1).HorizontalAlignment = xlCenter
Next i
'Now, while the recordset is available...
'The recordset has .fields.count fields
'Subtotals are wanted from field 7 to the end
If .Fields.Count > 13 Then
ReDim ary(14 To .Fields.Count - 1)
For i = LBound(ary) To UBound(ary)
ary(i) = i
Next i
wksNew.Cells(1, 1).CurrentRegion.SubTotal GroupBy:=1, _
TotalList:=ary, Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End If
.Close
End With
End Sub
I tried this code based on this website:
Dim rCell As Range
wksNew.Columns("A:A").Select
Dim rCell As Range
For Each rCell In Selection
If Right(rCell.Value, 5) = "Count" Then
Rows(rCell.Row).Interior.ColorIndex = 36
End If
Next
but it returned a "Method or data member not found" error on the item rCell.Value.
I also tried it like this:
Dim rCell As Range
wksNew.Columns("A:A").Select
For Each rCell In Selection
If Right(rCell, 5) = "Count" Then
Selection.Font.Bold = True
End If
Next
But I got the error "ActiveX component can't create object" on the For Each line.
How do I bold the entire row for the subtotals?

Answer 1

You're getting an error because Access doesn't know what Selection is unless you tell it that it's connected to your Excel instance.
For Each rCell In Selection
However, don't need to select anything, or check the whole column:
Dim rCell As Range
For Each rCell In wksNew.UsedRange.Columns(1).Cells
If Right(rCell, 5) = "Count" Then
rCell.Font.Bold = True
End If
Next

Answer 2

Have you tried a Pivot Table?? It is easier to manage format or layout and you don't have to change too much your code because you just put your RecordSet in a PivotTableCache like the second example in this.

Answer 3

Rather than looping, I'd suggest collapsing the outline and formatting the visible cells:
with wksNew.Cells(1, 1).CurrentRegion
.Outlinelevel = 2
.specialcells(12).Font.Bold = True
.Outlinelevel = 3
End With

Answer 4

Thanks for all the suggestions. No one posted a solution that worked entirely, so here's what I ended up using:
Dim c As Object
For Each c In wksNew.Range("A1:A500")
If c.Value Like "*Total" Then
c.Offset(0, 13).Font.Bold = True
c.Offset(0, 14).Font.Bold = True
c.Offset(0, 15).Font.Bold = True
End If
Next
The only thing that concerns me is that I'm assuming this only has 500 rows. I couldn't find a way to find the number of rows and have it search only those. If I included the whole column, it took a couple minutes to complete the loop which I didn't think the client would like. Any suggestions on how to find the last row?

Answer 5

I would
Display level 2 of the outline, all the subtotals
Select the whole area
Use GoTo Special to select only visible cells
Apply the formatting
Change the header row formatting if it should be different
Display all the levels again (level 3)
This code demonstrates:
Sub Macro4()
Application.ScreenUpdating = False
ActiveSheet.Outline.ShowLevels RowLevels:=2
Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Font.Bold = True
'change the header row if necessary
Range(Range("A1"), Range("A1").End(xlToRight)).Font.Italic = True
ActiveSheet.Outline.ShowLevels RowLevels:=3
End Sub