Formatting Excel Worksheets in VBA Code

If you need to sort, group, indent, or otherwise format exported data in an Excel worksheet, or create a total under the last row of data, you can write VBA code to use Excel commands to do the work in code. You can apply formatting to a worksheet created by the TransferSpreadsheet method, or one created from the Ribbon command, or a worksheet created programmatically from a template.

¡-77777-pr-™^ See Chapter 7 for examples of creating worksheets using the TransferSpreadsheet I^U&SOgMyJA method.

In this section, data from qryOrdersAndDetails is exported to a new worksheet made from a template and is then formatted in code. For convenience, the ExportNorthwindData procedure can be run from the macro mcrExportNorthwindData.

The procedure starts by creating a new worksheet from a template (Northwind Orders.xltx), as for the ArchiveData procedure. Data from the query qryOrdersAndDetails is written to rows in the worksheet, and then a set of Excel commands is used to apply hairline borders to the data area, and a double bottom border to the column headings row.

Next, the worksheets data area is sorted by the first two columns (Country and Category), and the extra values are removed (the effect is similar to turning on Hide Duplicates in an Access report). Finally, a Grand Total is created under the last row, made large and bold, and enclosed in a box. The procedure is listed as follows:

Public Sub ExportNorthwindData()

On Error GoTo ErrorHandler

Dim appExcel As Object

Dim i As Integer

Dim lngCount As Long

Dim lngCurrentRow As Long

Dim lngRows As Long

Dim n As Long

Dim objFind As Object

Dim rng As Excel.Range

Dim rngData As Excel.Range

Dim rngStart As Excel.Range

Dim strCategory As String

Dim strCountry As String

Dim strCurrAddress As String

Dim strDBPath As String

Dim strFormula As String

Dim strPrompt As String Dim strDataRange As String Dim strRange As String Dim strSaveName As String Dim strSheetName As String Dim strStartAddress As String Dim strTemplate As String Dim strTemplateFile As String Dim strTitle As String Dim wkb As Excel.Workbook Dim wks As Excel.Worksheet

Create a new worksheet from the template and export data to it:

strDBPath = Application.CurrentProject.Path & "\" Debug.Print "Current database path: " & strDBPath strTemplate = "Northwind Orders.xltx" strTemplateFile = strDBPath & strTemplate If TestFileExists(strTemplateFile) = False Then

Put up a message and exit if the template is not found:

strTitle = "Template not found"

strPrompt = "Excel template 'Northwind Orders.xlt'" _ & " not found in " & strDBPath & ";" & vbCrLf _ & "please put template in this folder and try again" MsgBox strPrompt, vbCritical + vbOKOnly, strTitle GoTo ErrorHandlerExit Else

Debug.Print "Excel template used: " & strTemplateFile End If

Set appExcel = GetObject(, "Excel.Application") Set dbs = CurrentDb

Create a recordset based on the Access query:

Set rst = dbs.OpenRecordset("qryOrdersAndDetails")

Create a new worksheet based on the template:

Set wkb = appExcel.Workbooks.Add(strTemplateFile) Set wks = wkb.Sheets(i) wks.Activate appExcel.Visible = True

Go to the first data cell in the worksheet:

Set rngStart = wks.Range("A4") Set rng = wks.Range("A4")

Reset lngCount to the number of records in the query:

rst.MoveLast rst.MoveFirst lngCount = rst.RecordCount

For n = 1 To lngCount

Write data from the recordset to cells in the current row of the worksheet, using the columnoff-set argument to move to the next cell:

rng.

.Value

= Nz(rst![ShipCountry])

Set

rng =

rng.Offset(columnoffset:

;=1

rng.

Value

= Nz(rst![Category])

Set

rng =

rng.Offset(columnoffset:

;=1

rng.

Value

= Nz(rst![Product])

Set

rng =

rng.Offset(columnoffset:

; =1

rng.

Value

= Nz(rst![Customer])

Set

rng =

rng.Offset(columnoffset:

; =1

rng.

Value

= Nz(rst![OrderID])

Set

rng =

rng.Offset(columnoffset:

; =1

rng.

Value

= Nz(rst![UnitPrice])

Set

rng =

rng.Offset(columnoffset:

=1

rng.

Value

= Nz(rst![Quantity])

Set

rng =

rng.Offset(columnoffset:

=1

rng.

Value

= Nz(rst![Discount])

Set

rng =

rng.Offset(columnoffset:

=1

rng.

Value

= Nz(rst![TotalPrice])

Go to the next row of the worksheet, using the rowoffset argument: rst.MoveNext

Set rng = rngStart.Offset(rowoffset:=n) Next n

Determine the number of data rows in the worksheet with the UsedRange property: lngRows = wks.UsedRange.Rows.Count

Debug.Print "Number of data rows in worksheet: " & lngRows

Define the data range:

strRange = "A4:I" & CStr(lngRows) Set rngData = wks.Range(strRange)

Apply hairline borders to the data range:

With rngData

.Borders(xlDiagonalDown).LineStyle = xlNone .Borders(xlDiagonalUp).LineStyle = xlNone

.Borders .Borders .Borders .Borders .Borders .Borders .Borders .Borders .Borders .Borders .Borders .Borders .Borders .Borders .Borders .Borders .Borders .Borders End With xlEdgeLeft).LineStyle = xlContinuous xlEdgeLeft).Weight = xlHairline xlEdgeLeft).ColorIndex = xlAutomatic xlEdgeTop).LineStyle = xlContinuous xlEdgeTop).Weight = xlHairline xlEdgeTop).ColorIndex = xlAutomatic xlEdgeBottom).LineStyle = xlContinuous xlEdgeBottom).Weight = xlHairline xlEdgeBottom).ColorIndex = xlAutomatic xlEdgeRight).LineStyle = xlContinuous xlEdgeRight).Weight = xlHairline xlEdgeRight).ColorIndex = xlAutomatic xlInsideVertical).LineStyle = xlContinuous xlInsideVertical).Weight = xlHairline xlInsideVertical).ColorIndex = xlAutomatic xlInsideHorizontal).LineStyle = xlContinuous xlInsideHorizontal).Weight = xlHairline xlInsideHorizontal).LineStyle = xlContinuous

Apply a double border to the bottom of the column headings row: wks.Rows("3:3").Select

With appExcel.Selection

.Borders(xlDiagonalDown).LineStyle = xlNone .Borders(xlDiagonalUp).LineStyle = xlNone .Borders(xlEdgeLeft).LineStyle = xlNone .Borders(xlEdgeTop).LineStyle = xlNone End With

With appExcel.Selection.Borders(xlEdgeBottom) .LineStyle = xlDouble .Colorlndex = 0 .TintAndShade = 0 .Weight = xlThick End With

With appExcel.Selection

.Borders(xlEdgeRight).LineStyle = xlNone .Borders(xlInsideVertical).LineStyle = xlNone End With

Sort the data range by country and category:

strDataRange = "A3:I" & CStr(lngRows) strKeylRange = "A4:AM & CStr(lngRows) strKey2Range = "B4:BM & CStr(lngRows) Debug.Print "Data range: " & strDataRange wks.Range(strDataRange).Select wks.Sort.SortFields.Clear wks.Sort.SortFields.Add Key:=Range(strKey1Range), _ SortOn:=xlSortOnValues, _ Order:=xlAscending, _ DataOption:=xlSortNormal wks.Sort.SortFields.Add Key:=Range(strKey2Range), _ SortOn:=xlSortOnValues, _ Order:=xlAscending, _ DataOption:=xlSortNormal With wks.Sort

.SetRange Range(strDataRange) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With

Remove the duplicate countries:

Set rng = wks.Range("A:A") For i = 4 To lngRows

Debug.Print rng.Cells(i, 1).Address & " contains " _ & rng.Cells(i, 1).Value

If rng.Cells(i, 1) = rng.Cells(i - 1, 1) Then rng.Cells(i, 1).Font.ColorIndex = 2 Elself rng.Cells(i, 1).Value <> strCountry Then Debug.Print "Different data in " _

& rng.Cells(i, 1).Address strCountry = rng.Cells(i, 1).Value End If Next i

Remove the duplicate categories:

Set rng = wks.Range("B:B") For i = 4 To lngRows

Debug.Print rng.Cells(i, 1).Address & " contains " _ & rng.Cells(i, 1).Value

If rng.Cells(i, 1).Value = rng.Cells(i - 1, 1) Then rng.Cells(i, 1).Font.ColorIndex = 2 Elself rng.Cells(i, 1).Value <> strCategory Then Debug.Print "Different data in " _

& rng.Cells(i, 1).Address strCategory = rng.Cells(i, 1).Value End If Next i

Add a Grand Total, and format its cell:

strFormula = "=SUM(R[-" & CStr(lngRows - 2) _

& "]C:R[-1]C)" Debug.Print "Formula: " & strFormula strRange = "I" & CStr(lngRows + 2) Debug.Print "Range: " & strRange wks.Range(strRange).FormulaR1C1 = strFormula wks.Range(strRange).Select

With appExcel.Selection.Font .Name = "Calibri" .Size = 14

.Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False

.Underline = xlUnderlineStyleNone .ThemeColor = 2 .TintAndShade = 0 .ThemeFont = xlThemeFontMinor End With

With appExcel.Selection .Font.Bold = True

.Borders(xlDiagonalDown).LineStyle = xlNone .Borders(xlDiagonalUp).LineStyle = xlNone End With

With appExcel.Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Colorlndex = 0 .TintAndShade = 0 .Weight = xlMedium End With

With appExcel.Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Colorlndex = 0 .TintAndShade = 0 .Weight = xlMedium End With

With appExcel.Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Colorlndex = 0 .TintAndShade = 0 .Weight = xlMedium End With

With appExcel.Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Colorlndex = 0 .TintAndShade = 0 .Weight = xlMedium End With

With appExcel.Selection

.Borders(xlInsideVertical).LineStyle = xlNone .Borders(xlInsideHorizontal).LineStyle = xlNone End With

Save and close the filled-in worksheet, using a workbook save name with the date range:

strSheetName = "Northwind Orders as of " _

& Format(Date, "d-mmm-yyyy") Debug.Print "Sheet name: " & strSheetName

Write the title with the date range to the worksheet:

wks.Range("A1M).Value = strSheetName strSaveName = strDBPath & strSheetName & ".xlsx" Debug.Print "Time sheet save name: " & strSaveName

ChDir strDBPath

On Error Resume Next

If there already is a saved worksheet with this name, delete it: Kill strSaveName

On Error GoTo ErrorHandler wkb.SaveAs FileName:=strSaveName, _

FileFormat:=xlWorkbookDefault wkb.Close rst.Close

Put up a success message with the name and path of the new worksheet: strTitle = "Workbook created"

strPrompt = strSheetName & vbCrLf & "created in " _ & strDBPath

MsgBox strPrompt, vbOKOnly + vblnformation, strTitle

ErrorHandlerExit: Exit Sub

ErrorHandler:

'Excel is not running; open Excel with CreateObject

If Err.Number = 429 Then

Set appExcel = CreateObject("Excel.Application") Resume Next Else

MsgBox "Error No: " & Err.Number & "; Description: " _

& Err.Description Resume ErrorHandlerExit End If

End Sub

A finished worksheet is shown in Figure 3.13.

FIGURE 3.13

A worksheet filled with data and formatted using VBA code.

FIGURE 3.13

A worksheet filled with data and formatted using VBA code.

0 0

Post a comment