Minimally Formatted Worksheets

If you need to create a simple tabular worksheet listing the contacts in qryContacts, with minimal formatting, you can create a new workbook in VBA code, from a saved workbook template with a title, correctly sized columns, and the font and other layout of your choice, and fill it with Access data. The ExportContactsToExcel procedure creates a recordset based on qryContacts, and exports selected fields from each record in that query to a workbook created from a template, with a title, column headings, and some minimal formatting:

Public Function ExportContactsToExcel()

On Error GoTo ErrorHandler

Dim dbs As DAO.Database

Dim rst As DAO.Recordset

Dim strWorksheetPath As String

Dim appExcel As Excel.Application

Dim strTemplatePath As String

Dim bks As Excel.Workbooks

Dim rng As Excel.Range

Dim rngStart As Excel.Range

Dim strTemplateFile As String

Dim wkb As Excel.Workbook

Dim wks As Excel.Worksheet

Dim lngCount As Long

Dim strPrompt As String

Dim strTitle As String

Dim strTemplateFileAndPath As String

Dim prps As Object

Dim strSaveName As String

Dim strTestFile As String

Dim strDefault As String

Set appExcel = GetObject(, "Excel.Application") strTemplatePath = GetWorksheetTemplatesPath strTemplateFile = "Access Contacts.xltx" strTemplateFileAndPath = strTemplatePath _ & strTemplateFile

Check for the template in the selected template folder, and exit if not found:

strTestFile = Nz(Dir(strTemplateFileAndPath)) Debug.Print "Test file: " & strTestFile If strTestFile = "" Then

MsgBox strTemplateFileAndPath _ & " template not found; " _ & "can't create worksheet" GoTo ErrorHandlerExit End If strWorksheetPath = GetWorksheetsPath Debug.Print "Worksheet template and path: " _ & strTemplateFileAndPath

Set a reference to the workbook and worksheet, and activate the worksheet:

Set bks = appExcel.Workbooks

Set wkb = bks.Add(strTemplateFileAndPath)

wks.Activate

Set a reference to the query:

Set dbs = CurrentDb

Set rst = dbs.OpenRecordset("qryContacts", _

dbOpenDynaset) rst.MoveLast rst.MoveFirst lngCount = rst.RecordCount If lngCount = 0 Then

MsgBox "No contacts to export" GoTo ErrorHandlerExit Else strPrompt = "Exporting " & lngCount _

& " contacts to Excel" strTitle = "Exporting"

MsgBox strPrompt, vblnformation + vbOKOnly, strTitle End If

Go to the first data cell:

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

Loop through the recordset, importing each record to a cell in the worksheet:

With rst

Do Until .EOF

Write Access data from a record directly to cells in the worksheet: rngStart.Activate rngStart.Value = Nz(![ContactID]) Set rng = _

appExcel.ActiveCell.Offset(columnoffset:=1) rng.Value = Nz(![CompanyName]) Set rng = _

appExcel.ActiveCell.Offset(columnoffset:=2) rng.Value = Nz(![FirstName]) Set rng = _

appExcel.ActiveCell.Offset(columnoffset:=3) rng.Value = Nz(![LastName]) Set rng = _

appExcel.ActiveCell.Offset(columnoffset:=4) rng.Value = Nz(![Salutation]) Set rng = _

appExcel.ActiveCell.Offset(columnoffset:=5) rng.Value = Nz(![StreetAddress]) Set rng = _

appExcel.ActiveCell.Offset(columnoffset:=6) rng.Value = Nz(![City]) Set rng = _

appExcel.ActiveCell.Offset(columnoffset:=7) rng.Value = Nz(![StateOrProvince]) Set rng = _

appExcel.ActiveCell.Offset(columnoffset:=8) rng.Value = Nz(![PostalCode]) Set rng = _

appExcel.ActiveCell.Offset(columnoffset:=9) rng.Value = Nz(![Country]) Set rng = _

appExcel.ActiveCell.Offset(columnoffset:=10) rng.Value = Nz(![JobTitle])

Go to the first column of the next row:

rngStart.Activate Set rngStart = _

appExcel.ActiveCell.Offset(rowoffset:=1) .MoveNext

Loop End With

MsgBox "All Contacts exported!"

Get the save name from workbook's Title property: Set prps = _

appExcel.ActiveWorkbook.BuiltinDocumentProperties strSaveName = strWorksheetPath & prps("Title") _

& " - " & Format(Date, "d-mmm-yyyy") Debug.Print "Worksheet save name: " & strSaveName

On Error Resume Next

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

Kill strSaveName

On Error GoTo ErrorHandler strPrompt = "Enter file name and path for saving worksheet" strTitle = "File name" strDefault = strSaveName strSaveName = InputBox(prompt:=strPrompt, _ Title:=strTitle, Default:=strDefault)

wkb.SaveAs FileName:=strSaveName, _

FileFormat:=xlWorkbookDefault appExcel.Visible = True

ErrorHandlerExit: Exit Sub

ErrorHandler:

Excel is not running; open Excel with CreateObject:

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

& "; Description: " & Err.Description Resume ErrorHandlerExit End If

End Sub

The procedure first picks up the worksheet template path from the main menu, checks that the template is to be found in that location, and then creates a new workbook from the template. It then sets up a recordset based on an Access query, goes to the first data cell in the worksheet, and starts iterating through the records in the recordset, using the Offset method of the active cell to place data from each field in the correct column.

When all the contacts have been exported to the worksheet, a save name is constructed from the templates Title property and the current date, and displayed in an InputBox so it can be edited, if desired; finally, the worksheet is saved with the save name and made visible.

The ExportContactsToExcel procedure in this section can be run from the macro mcrExportContactsToExcel.

The resulting worksheet is shown in Figure 7.7.

FIGURE 7.7

A minimally formatted worksheet filled with Access data.

FIGURE 7.7

A minimally formatted worksheet filled with Access data.

0 0

Post a comment