The Challenge

My goal was to automate the process of copying values from an Access PivotTable to another Office program, like Word or PowerPoint.  It is possible to manually copy the values from an Access PivotTable to the clipboard by selecting a data cell, using Ctrl-A to select all of the PivotTable, and then using Ctrl-C to copy.  However, when I tried to figure out how to do the same steps using VBA, I could not determine how to select a cell.  There may be a solution by embedding the PivotTable form into another form and referencing the PivotTable object directly, but it would require referencing the Office Web Components library, which changed DLLs from Access 2003 (which used the Access 2002 version) and Access 2007.  I have clients using both 2003 and 2007, so I opted for a simpler solution which did not require referencing an extra library.

The Solution

The solution is to use the Export method of the PivotTable, which exports the pivot and the pivot data to Excel.  A file name for the export is not specified in the example because the export wants to create an HTML document, something like PivotTable62219.HTM, and an Excel file name confuses it.  Once in Excel, the pivot table becomes more familiar and automation is used to copy just the pivot values and formatting to another worksheet.  Then the range that has values is copied to the clipboard.  At the end of the function, the Excel application is left open so that the values remain on the clipboard.  The GetSaveAsFilename method of the Excel application object is used to allow the user to save the results as an Excel workbook.

Below are examples of the Access PivotTable and the Excel results.  In my example, I merged the PivotTable column headers into one title for the Excel results.

Late Binding

Late binding is used because I wasn’t sure what version of Excel my users may have installed.  It is easier to use early binding (like Dim objExcelApp As Excel.Application), which provides IntelliSense for the Excel objects.  I often start with early binding, referencing the Excel library I have installed (by using the Tools, References option on the VBA editor toolbar), and then change to late binding after the code is tested.  Late binding also requires a list of Excel constants to be defined, which I found values for by using the object browser in a session of Excel VBA.

Notes

• If you are using only Excel 2007, you can change the default file name and filter for the GetSaveAsFilename method to use the new extension, .xlsx.
• The function XAddress() is a custom function that you can find here.

Code:

Public Function ExportCopyAccessPTValues(PTForm) As Boolean
' This function exports the values from the Microsoft Access pivottable
' form PTForm to Microsoft Excel.  In Excel, it leaves just the values
' and formatting, and then copies the results to the clipboard.

' For example, you may call the function like:
' ExportCopyAccessPTValues(Forms!frmStudentData)

' ExportCopyAccessPTValues() Version 1.0.0
' Copyright © 2009 Extra Mile Data, www.extramiledata.com.
' For questions or issues, please contact [email protected].
' Use (at your own risk) and modify freely as long as proper credit is given.

On Error GoTo Err_ExportCopyAccessPTValues

    Const plExportActionOpenInExcel As Long = 1
    Dim varFileName
    Dim lngStart As Long
    Dim strLC As String

    ' Excel objects
    Dim objExcelApp
    Dim objWB
    Dim objWS
    Dim objPT

    ' Excel constants
    Const xlByRows = 1
    Const xlContinuous = 1
    Const xlDataAndLabel = 0
    Const xlDown = -4121
    Const xlEdgeBottom = 9
    Const xlEdgeLeft = 7
    Const xlEdgeRight = 10
    Const xlEdgeTop = 8
    Const xlFormatFromLeftOrAbove = 0
    Const xlLastCell = 11
    Const xlNone = -4142
    Const xlNormal = -4143
    Const xlPart = 2
    Const xlPasteFormats = -4122
    Const xlPasteValuesAndNumberFormats = 12
    Const xlThin = 2
    Const xlUp = -4162

    ' Export the pivot to Excel, without a file name.
    PTForm.PivotTable.Export , plExportActionOpenInExcel

    ' Time delay because Excel takes a moment to open and
    ' it must be fully open with the pivot in view before we
    ' can continue.
    lngStart = Timer
    Do While Timer < lngStart + 3
        DoEvents
    Loop

    ' Get the Excel application.  It will get one that is already
    ' open, or start a new one.
    Set objExcelApp = GetObject(, "Excel.Application")

    With objExcelApp

        ' Make Excel visible.
        .Visible = True

        ' Get the workbook object.
        Set objWB = .ActiveWorkbook

        ' Get the worksheet object.
        Set objWS = objWB.ActiveSheet

        ' Get the pivottable object, select all the data, and copy it.
        Set objPT = objWS.PivotTables(1)
        objPT.PivotSelect "", xlDataAndLabel, True
        .Selection.Copy

        ' Add a new worksheet.
        objWB.Sheets.Add After:=objWB.Sheets(objWB.Sheets.Count)

        ' Use Paste Special to paste the pivottable to the new worksheet,
        ' Values and Number Formats, then Formats.
        .Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .Selection.PasteSpecial Paste:=xlPasteFormats, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=False

        ' Insert a row.
        .CutCopyMode = False
        .Range("A1").EntireRow.Insert Shift:=xlDown, _
            CopyOrigin:=xlFormatFromLeftOrAbove

        ' In A1, concatenate the possible pivot grouping captions.
        .Range("A1").FormulaR1C1 = _
            "=TRIM(R[1]C[1] & "" "" & R[1]C[2] & "" "" & R[1]C[3] & "" "" " _
            & "& R[1]C[4] & "" "" & R[1]C[5])"

        ' Paste the Formats from B2 to A1.
        .Range("B2").Copy
        .Range("A1").PasteSpecial Paste:=xlPasteFormats, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=False

        ' Now copy over the formula in A1 with the Values and Number Formats from A1.
        .Range("A1").Copy
        .Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=False

        ' Delete the second row, no longer needed.
        .Range("A2").EntireRow.Delete Shift:=xlUp

        ' Put borders around A2.
        .Range("A2").Select
        With .Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .Weight = xlThin
        End With
    ' For some reason, this creates an error.
    '    With .Selection.Borders(xlEdgeTop)
    '        .LineStyle = xlContinuous
    '        .ColorIndex = 0
    '        .Weight = xlThin
    '    End With
        With .Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .Weight = xlThin
        End With
        With .Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .Weight = xlThin
        End With

        ' Merge the cells in the title row.  This will allow the table
        ' to work well when it is pasted in another application.
        ' Start by selecting the whole range of used data.
        .Range("A1", .ActiveCell.SpecialCells(xlLastCell)).Select
        ' Find the last column and build an address for the last cell in
        ' the row that has data.  Use that address for the right cell in the
        ' range to select and A1 for the left cell.
        strLC = XAddress(.Selection.Address, xatLastColumn)
        .Range("A1", strLC & "1").Select
        ' Then merge.
        .Selection.Merge True

        ' Put borders around the merged section.
        With .Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .Weight = xlThin
        End With
        With .Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .Weight = xlThin
        End With
        With .Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .Weight = xlThin
        End With
        With .Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .Weight = xlThin
        End With

        ' Replace the "Grand Total" caption with "Overall".
        .Cells.Replace _
            What:="Grand Total", Replacement:="Overall", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False

        ' Give specific column widths.
        .Columns("A:" & strLC).ColumnWidth = 6

        ' AutoFit the first column because of the "Overall" caption.
        .Columns("A:A").EntireColumn.AutoFit

        ' Turn off user messages.
        .DisplayAlerts = False
        objWB.Sheets("Sheet1").Delete
        ' Delete the first two worksheets that have the original pivottable
        ' and the pivottable data.
        objWB.Sheets("Sheet2").Delete

        ' Select the data and copy it to that it is ready to paste elsewhere.
        .Range(objExcelApp.Selection, _
            objExcelApp.ActiveCell.SpecialCells(xlLastCell)).Select
        .Selection.Copy

        ' Get a file name from the user; provide a default.  If the user
        ' clicks Save, then save the workbook.
        varFileName = .GetSaveAsFilename("Pivot Results.xls", _
            "Excel Files (*.xls),*.xls")
        If varFileName = False Then
            ' User canceled save.  Do nothing.
        Else
            ' Save the file with the name selected by the user.
            objWB.SaveAs varFileName, FileFormat:=xlNormal
        End If

        ExportCopyAccessPTValues = True

    End With 'objExcelApp

Exit_ExportCopyAccessPTValues:
    On Error Resume Next
    objExcelApp.DisplayAlerts = True
    ' We do not actually close the Excel application because
    ' if we do, the clipboard appears to get cleared out.
    Set objPT = Nothing
    Set objWS = Nothing
    Set objWB = Nothing
    Set objExcelApp = Nothing
    Exit Function

Err_ExportCopyAccessPTValues:
    MsgBox Err.Number & " " & Err.Description, vbCritical, "ExportCopyAccessPTValues()"
    ExportCopyAccessPTValues = False
    Resume Exit_ExportCopyAccessPTValues

End Function

Download Code: basExportCopyAccessPTValues.zip