Ms Excel Fast Formatting and outlining using Autofilter

Discuss at phorum: http://zmey.1977.ru/phorum/viewtopic.php?t=10

See also: Ways to transfer MS Access data to Excel

See also: Autosum project

This article concerns fast formatting of data in MS Excel. The methods described were originally developed to apply various formatting to MS Excel worksheets created from MS Access using Automation. However all these methods work as well when applied in MS Excel itself.

Creating worksheets
Formatting text
Creating Outline and Indent
Drawing Hierarchical Headers

Creating worksheets

There is common method to add worksheet to workbook. However it can save much of your time if you know apriory how much pages there will be in the workbook and create a book with required number of pages.

Sample:

Dim XL as Object
Dim WB as Workbook

Set XL = CreateObject("excel.application")

XL.SheetsInNewWorkbook = 20 'enter your numsheets here

Set WB = XL.Workbooks.Add

So now we have workbook WB with 20 worksheets which we can access using WB.Worksheets( N ) where N is 1 based number of worksheet.
However it may appear faster to use the following technique: if you have workbook with many worksheets of the same format, which differs only in data, you may create and format one sheet then use
Worksheet.Copy After:=Sheet1 and then wipe old data and apply new. If time is critical both ways should be tested.
Notice, that each worksheet has a Name property (which is what you see on tab) and CodeName property which is inner name for worksheet (you can see code name in VBA Editor for example). So, when you copy worksheet, the new code name will be the old one added with "1" string. Doing this many times may lead to error as described here:
http://support.microsoft.com/default.aspx?scid=kb;en-us;236299

Formatting text

Text formatting is not a problem since you understood MS excel object model.
Few tips to make it faster:
If possible, don't format worksheet cell by cell, especially conditional format. Lots of time wasted to read cell value and activate next cell. So, if the whole range of cells has the same format, it's great time-saving to apply this format to whole range, not to single cell. You can also use FillAcrossSheets method to copy formats to all the (or some of the) sheets in workbook.

Worksheets.FillAcrossSheets Sheets(1).Cells(1,1),xlFillWithFormats

The most powerful way to apply formatting to unbound ranges is to use AutoFilter.
Lets say you have worksheet object WS and square range on it with top left corner x,y and m and n width and height.

With WS.Range(WS.Cells(y - 1, x), WS.Cells(y + n, x + m))

.AutoFilter 1, "=a*"

.Columns(1).Font.Bold = True
.Font.Size = 14
.Columns(1).Font.Name = "Times New Roman Cyr"

WS.AutoFilterMode = False

End with

Let's explain the code. Block with used to point, which range to work with. Notice, that it's started to y-1 row, we'll explain that later. In .Autofilter 1 is column number (relative to range), second argument is condition. So after using autofilter we have only rows started with a. Then we apply format (notice, that bold applied to first column and font size to all cells. When we remove autofilter we have formatted only these rows, which we filtered.
To apply conditional format you may have one field drawn from access database, which later will be deleted, containing FormatID. Then you filter them one by one and apply required formats and delete the column with FormatID.
There is one unpleasant moment in this technology. When apply format to filtered range you'll have first row formatted as well, regardless to condition. So, then applying formats one by one you'll have first row formatted as if it has las used FormatID. To avoid that there are several methods. For example, if you know what is FormatID of the first row you can apply that format last. I prefer to format range including one row higher than first (y-1 in the sample) and delete or hide it later.

Creating Outline and Indent


Applying of autofilter it is also possible to create outline in a fast and quite a simple way:
We modify preceding sample:

With WS.Range(WS.Cells(y - 1, x), WS.Cells(y + n, x + m))

.AutoFilter 1, "=a*"

.IndentLevel = 5
Call NewGroup(.SpecialCells(xlCellTypeVisible))
WS.AutoFilterMode = False

End with


Sub NewGroup(R As Range)
Dim rr As Range
If R.Areas.Count > 0 Then
For Each rr In R.Areas
rr.rows.Group
Next rr
End If

R.Worksheet.Outline.SummaryRow = xlSummaryAbove

End Sub


After filtering rows we set the indent level and call the NewGroup Function. New Group accept range as argument, the trick is that using .SpecialCells(xlCellTypeVisible) we pass to subroutine undound range of filtered group of rows. So, in NewGroup for each area we perform the group operation.
This row:
.Worksheet.Outline.SummaryRow = xlSummaryAbove
used to display "+" symbol on top of the group.

Drawing Hierarchical Headers

Below is a function, which helps you to draw hierarchical headers on given worksheet. By hierarchical header (hh) I mean that you set first row (a,b,c) then second (1,2) and have a result on a page that shows:

a
b
c
1
2
1
2
1
2


You can specify as much "floors" as you wish, and you can set "irregular" headers (for example in C column there may be not 2 subcolumns, but 5 with different names. Finally, setting Palki option to true, you will have a borders drawn in a row below the lowest flow, and borders between A, B and C will be thick and between 1 and 2 will be thin. Later you can copy / past formats to whole range of data and all the columns will be divided as described. That's a bit complicated to call that function, but if you'll spend some times with example you'll understand.

Public Function Test()

Dim XL As Object
Dim WB As Workbook
Dim WS As Worksheet
Dim n As Long, m As Long
Dim x As Long
Dim y As Long
Dim labels As Variant

Set XL = CreateObject("excel.application")

XL.SheetsInNewWorkbook = 1

XL.Visible = True

Set WB = XL.Workbooks.Add

Set WS = WB.Worksheets(1)

'uncomment different labels for sample

labels = Array(Array("a", "b", "c"), Array("1", "2"))
'simple sample

'labels = Array(Array("a", "b", "c"), Array("1", "2"), Array("aa", "bb", "cc", "dd"))
'3 floors

'labels = Array(Array(Array("a", "b"), Array("1", "2"), Array("aa", "bb", "cc", "dd")), Array(Array("c"), Array("c1", "c2", "c3"), Array("ca", "cb", "cc", "cd")))
'irregular

x = 5
y = 5
'topleft

Call SuperDrawWanka(WS, x, y, n, m, labels, True)

'formatting goes after
With WS.Cells(y, x).CurrentRegion
.Columns.AutoFit
.HorizontalAlignment = xlHAlignCenter
.Borders.Weight = xlMedium
End With

'Set XL = Nothing

End Function

Function SuperDrawWanka(WS As Worksheet, ByRef x As Long, ByRef y As Long, ByRef n As Long, ByRef m As Long, labels As Variant, Optional palki As Boolean = False)

Dim xtemp As Long
Dim i, j As Integer
Dim k As Integer
Dim tc As Integer
Dim bc As Integer
Dim newlabels() As Variant
Dim irregularlabels As Variant
Dim dum As Variant


tc = UBound(labels(0)) - LBound(labels(0))

For i = 0 To tc

If TypeName(labels(0)(i)) = "Variant()" Then
For j = 0 To UBound(labels)
Call SuperDrawWanka(WS, x, y, n, m, labels(j), palki)
Next j
Exit Function

Else
If UBound(labels, 1) = 1 Then
If TypeName(labels(1)(0)) = "Variant()" Then

For j = 0 To UBound(labels(1))
Call SuperDrawWanka(WS, x, y + 1, n, m, labels(1)(j), palki)
Next j

With WS
.Range(.Cells(y, x), .Cells(y, x + m - 1)).Merge
.Range(.Cells(y, x), .Cells(y, x + m - 1)).Value = labels(0)(i)
End With

Exit Function
End If

bc = UBound(labels(1)) - LBound(labels(1))
With WS

ReDim dum(UBound(labels(1)))

For k = 0 To UBound(labels(1))
dum(k) = LongestWord(CStr(labels(1)(k)), " ")
Next k


.Range(.Cells(y, x + m), .Cells(y, x + m + (bc + 1) - 1)).Merge
.Range(.Cells(y, x + m), .Cells(y, x + m + (bc + 1) - 1)).Value = labels(0)(i)

.Range(.Cells(y + 1, x + m), .Cells(y + 1, x + m + (bc + 1) - 1)).Value = dum
.rows(y + 1).AutoFit
.Range(.Cells(y + 1, x + m), .Cells(y + 1, x + m + (bc + 1) - 1)).EntireColumn.AutoFit

.Range(.Cells(y + 1, x + m), .Cells(y + 1, x + m + (bc + 1) - 1)).Value = labels(1)

.Range(.Cells(y, x + m), .Cells(y, x + m + (bc + 1) - 1)).Merge
.Range(.Cells(y, x + m), .Cells(y, x + m + (bc + 1) - 1)).Value = labels(0)(i)
If palki Then
.Range(.Cells(y + 2, x + m), .Cells(y + 2, x + m + (bc + 1) - 1)).Borders(xlEdgeLeft).Weight = xlMedium
.Range(.Cells(y + 2, x + m), .Cells(y + 2, x + m + (bc + 1) - 1)).Borders(xlEdgeRight).Weight = xlMedium
.Range(.Cells(y + 2, x + m), .Cells(y + 2, x + m + (bc + 1) - 1)).Borders(xlInsideVertical).Weight = xlThin
End If
m = m + bc + 1
End With
Else

ReDim newlabels(UBound(labels, 1) - 1)
For j = 1 To UBound(labels, 1)
newlabels(j - 1) = labels(j)
Next j

xtemp = x + m
Call SuperDrawWanka(WS, x, y + 1, n, m, newlabels, palki)
With WS
.Range(.Cells(y, xtemp), .Cells(y, x + m - 1)).Merge
.Range(.Cells(y, xtemp), .Cells(y, x + m - 1)).Value = labels(0)(i)
End With

End If
End If


Next i

End Function


© Andrew Semenov 2003
All rights reserved