I need to export a query to Excel pivot table

[gfranco]

I have a project to elaborate, I have my base data and i need to convert it
onto Pivot TAble worksheet, let me know ho can I do it, thanks

Public Sub PivotTableExportData()
Dim xlapp As Excel.Application
Dim xlwb As Excel.Workbook
Dim xlws As Excel.Worksheet
Dim xlrng As Excel.Range
Dim xlPivot As Excel.PivotTable
Dim adors As ADODB.Recordset
Dim adofld As ADODB.Field
Dim x, y, z As Integer

Set xlapp = New Excel.Application
xlapp.Visible = True
Set xlwb = xlapp.Workbooks.Add
Set xlws = xlwb.ActiveSheet
xlws.Name = "BaseData"

Set adors = New ADODB.Recordset
adors.Open "qryTotalByPartner", CurrentProject.Connection, adOpenStatic,
adLockReadOnly



x = 1
For Each adofld In adors.Fields
xlws.Cells(1, x).Value = adofld.Name
x = x + 1
Next adofld

'Set xlrng = xlws.Cells(2, 1)
Set xlrng = xlws.Cells(3, 1)
xlrng.CopyFromRecordset adors
y = adors.RecordCount + 1
adors.Close

Set xlws = xlwb.Worksheets.Add
xlws.Name = "PartnerPivot"
Set xlrng = xlws.Range("A3")


xlws.PivotTableWizard Excel.xlDatabase, "BaseData!R1C1:R646C16" & y & "C" &
x - 1, _
xlrng, "PartnerPivotTable", True, True, True, True

Set xlPivot = xlws.PivotTables("PartnerPivotTable")
xlPivot.AddFields "Customer", "Created"
With xlPivot.PivotFields("TotalCost")
.Orientation = Excel.xlDataField
.NumberFormat = "$#,##0.00"
End With

Set xlPivot = Nothing
Set xlrng = Nothing
Set xlws = Nothing
Set xlwb = Nothing
Set xlapp = Nothing
Set adofld = Nothing
Set adors = Nothing
End Sub

Public Sub PivotTableChartExportData()
Dim xlapp As Excel.Application
Dim xlwb As Excel.Workbook
Dim xlws As Excel.Worksheet
Dim xlrng As Excel.Range
Dim xlPivot As Excel.PivotTable
Dim adors As ADODB.Recordset
Dim adofld As ADODB.Field
Dim x, y, z As Integer

Set xlapp = New Excel.Application
xlapp.Visible = True
Set xlwb = xlapp.Workbooks.Add
Set xlws = xlwb.ActiveSheet
xlws.Name = "BaseData"

Set adors = New ADODB.Recordset
adors.Open "qryTotalByPartner", CurrentProject.Connection, adOpenStatic,
adLockReadOnly



x = 1
For Each adofld In adors.Fields
xlws.Cells(1, x).Value = adofld.Name
x = x + 1
Next adofld

Set xlrng = xlws.Cells(2, 1)
xlrng.CopyFromRecordset adors
y = adors.RecordCount + 1
adors.Close

Set xlws = xlwb.Worksheets.Add
xlws.Name = "SalesPivot"
Set xlrng = xlws.Range("A3")


xlws.PivotTableWizard Excel.xlDatabase, "BaseData!R1C1:R" & y & "C" & x - 1, _
xlrng, "PartnerPivotTable", True, True, True, True

Set xlPivot = xlws.PivotTables("PartnerPivotTable")
xlPivot.AddFields "Customer", "Created"
'xlPivot.AddFields "LineofBusiness2", "ProductCategory"
With xlPivot.PivotFields("TotalCost")
.Orientation = Excel.xlDataField
.NumberFormat = "$#,##0.00"
End With

xlwb.Charts.Add
ActiveChart.SetSourceData xlrng
ActiveChart.Location Where:=Excel.xlLocationAsNewSheet


Set xlPivot = Nothing
Set xlrng = Nothing
Set xlws = Nothing
Set xlwb = Nothing
Set xlapp = Nothing
Set adofld = Nothing
Set adors = Nothing
End Sub

 

[Jeanette Cunningham]

Hi,
I have seen this done in a slightly different way.
Setup a worksheet with typical data and create the pivot table or tables you
want based on the data.
Name the worksheet with the data for the pivot table as RawData
Save the worksheet to use as a template workbook.
Leave the pivot tables but delete the data, you might want to leave the
column headers.

Use the excel copy from recordset method to export your data from access to
a copy of the template workbook.
The exported data goes into the worksheet called RawData.
The pivot table now has the new data as its source data.

Jeanette Cunningham

 

[gfranco]

Jeanette,

If you have something on live, i would like to see for learning proposes.
Thanks

 

[Jeanette Cunningham]

Here is some code to export data to a template workbook.

'------------------------
'replace the following with your own strings
'strDocPath = "c:\documents and settings\Jeanette\desktop\TemplateB.xls"
'strPath = "c:\documents and settings\Jeanette\desktop\Text.xls"
'strFirstCell = "A5"
'strWsName = "Sheet1"
'strSQL can be a saved query,
'or a saved table,
'or a sql statement
'strSql = "SELECT yadda, yadda " _
' & "FROM yadda " _
' & "WHERE yadda " _
' & "ORDER BY yadda"
'if your template has more than 1 worksheet
'you can choose which worksheet will receive the data
'you can choose which cell to start copying the data to
'------------------------
Public Sub CopyRecordset2XLTemplate()
On Error GoTo SubErr
Dim objXLApp As Object 'Excel.Application
Dim objXLWs As Object 'Excel.Worksheet
Dim strWsName As String 'name of worksheet
Dim strFirstCell As String 'starting point to add the data
Dim rst As DAO.Recordset
Dim strDocPath 'full path and name of template
Dim strPath As String 'full path and name to save file as
Dim strSQL As String 'data to export, table, query or sql statement


Const xlCellTypeLastCell = 11
Const xlContinuous = 1
Const xlAutomatic = -4105


'strDocPath = "c:\documents and settings\Jeanette\desktop\TemplateB.xls"
'strPath = "c:\documents and settings\Jeanette\desktop\Text.xls"
'strFirstCell = "A5"
'strWsName = "Sheet1"
'strSQL = "QueryName"

strDocPath = "c:\documents and
settings\jc.ECJ-02.000\desktop\MyPersonxpt.xls"
strPath = "c:\documents and
settings\jc.ECJ-02.000\desktop\MyNewPersonxpt.xls"

strWsName = "S1"
'name of the recordset to copy
strSQL = "qryNewStatusExport"
strFirstCell = "A4"


'replace with names and cell references that suit your template

' Populate the excel object
Set objXLApp = CreateObject("Excel.Application")
' Open the template workbook
objXLApp.Workbooks.Open (strDocPath)
' Save the template as the file specified by the user
objXLApp.ActiveWorkbook.SaveAs (strPath)

'Open a recordset on the table with query and worksheet names
Set rst = CurrentDb.OpenRecordset(strSQL)
If rst.EOF Then
'handle error here
Else
' Select the appropriate worksheet
Set objXLWs = objXLApp.ActiveWorkbook.Worksheets(strWsName)
' Activate the selected worksheet
objXLWs.Activate
' Ask Excel to copy the data from the recordset starting with
strFirstCell
objXLWs.Range(strFirstCell).CopyFromRecordset rst

' Select the main worksheet
objXLApp.Worksheets(strWsName).Activate
' Activate the selected worksheet
Set objXLWs = objXLApp.ActiveWorkbook.Worksheets(strWsName)
'format cells
With objXLWs.Cells
.Range(.Cells(1, 1), .Cells(1, _
1).SpecialCells(xlCellTypeLastCell)).Borders.LineStyle = _
xlContinuous
.Range(.Cells(1, 1), .Cells(1, _
1).SpecialCells(xlCellTypeLastCell)).Borders.ColorIndex = _
xlAutomatic
.Font.Size = 9
.Font.Name = "Arial Narrow"
.WrapText = True

End With

End If


'**error handling, in the Sub exit - make sure you set the object
'references to nothing as shown below.

SubExit:
' Save the workbook
objXLApp.ActiveWorkbook.Save
Set objXLWs = Nothing
Set objXLApp = Nothing
' Destroy the recordset and database objects
rst.Close
If Not rst Is Nothing Then
Set rst = Nothing
End If

Exit Sub

SubErr:
MsgBox Err.Description & " " & Err.Number
Resume SubExit
End Sub


Jeanette Cunningham