How to copy pivot table RESULT from Access to Excel
I need to produce a highly formated pivot table report in Access and can only achieve so much. However, if I could programatically select the pivot table (equivalent of keys [Ctrl]+
) then copy and paste into Excel, I can use VBA to format the report in Excel.
My problem is that I cannot find a way to programatically select the pivot table in Access. I have tried Sendkeys "^A" as a last resort but this doesn't work. Exporting to Excel doesn't work either as it exports the pivot table, not the result.
[721 byte] By [
Rick3021] at [2007-12-24]
Try this.
"str_spreadsheet_name" holds the name of a file that has already been exported and Excel is open and running.
"obj_xls" then picks up the open spreadsheet.
It then creates pivot table called "Holdings" in the Excel sheet at AQ1, with rows being "rec_id", columns being "fund_name" and pivot field being "sum of fund_value".
It then copies the pivot table and does a patsespecial - values only. This removes all of the pivot table formatting.
It then tidies up the headings etc. If you run the process in debug you'll be able to see it working line by line.
Hope this is of use.
KD
Private Function reformat_fund_totals()
On Error GoTo Err_reformat_fund_totals
Dim rst_temp As New ADODB.Recordset
Dim cmd_sp As New ADODB.Command
Dim obj_xls As Object
Dim int_rows As Integer
Dim str_col As String
Dim str_addr As String
Dim objPivotCache As PivotCache
DoCmd.Hourglass True
DoCmd.Echo False
Set cnn_db = CurrentProject.Connection
Set obj_xls = CreateObject("Excel.Sheet")
Dim start_time As Long
Dim bool_isrunning As Boolean
start_time = Timer
bool_isrunning = False
On Error Resume Next' Defer error trapping.
Do While Timer < start_time + 30
Set obj_xls = GetObject(str_spreadsheet_name).Application
If Err.Number = 0 Then
bool_isrunning = True
Exit Do
End If
Err.clear' Clear Err object in case error occurred.
Loop
If bool_isrunning = False Then
DoCmd.Hourglass False
DoCmd.Echo True
MsgBox "Failure formatting report " & strReport_name & " - Please inform IT", vbCritical, "SIC"
Exit Function
End If
str_col = ""
int_rows = 0
If Forms!frm_rp05_parameters!holdings_reqd = "Y" Then
str_sql = "EXEC sp_rpt183_fund_holdings " & pub_session_id
Set cmd_sp.ActiveConnection = cnn_db
cmd_sp.CommandText = str_sql
cmd_sp.CommandType = adCmdText
cmd_sp.Execute
Set rst_temp.ActiveConnection = cnn_db
rst_temp.Open cmd_sp
' Create a PivotTable cache and report.
Set objPivotCache = obj_xls.ActiveWorkbook.PivotCaches.Add(SourceType:=xlExternal)
Set objPivotCache.Recordset = rst_temp
With objPivotCache
.CreatePivotTable TableDestination:=obj_xls.Range("AQ1"), TableName:="Holdings"
End With
With obj_xls.ActiveSheet.PivotTables("Holdings").PivotFields("rec_id")
.Orientation = xlRowField
.Position = 1
End With
With obj_xls.ActiveSheet.PivotTables("Holdings").PivotFields("fund_name")
.Orientation = xlColumnField
.Position = 1
End With
obj_xls.ActiveSheet.PivotTables("Holdings").AddDataField obj_xls.ActiveSheet.PivotTables("Holdings").PivotFields("fund_value"), "Sum of fund_value", xlSum
DoEvents
obj_xls.ActiveSheet.PivotTables("Holdings").PivotSelect "", xlDataAndLabel, True
obj_xls.Selection.Copy
obj_xls.Range("AQ1").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
obj_xls.Range("AQ1:IV1").Delete Shift:=xlUp
obj_xls.columns("AQ:AR").Delete Shift:=xlToLeft
'Get last row of data
str_addr = obj_xls.Range("A1", obj_xls.Range("A1").End(xlDown)).Address
int_rows = Right(str_addr, Len(str_addr) - InStrRev(str_addr, "$"))
'Get last column of data
str_addr = obj_xls.Range("A1", obj_xls.Range("A1").End(xlToRight)).Address
str_col = Mid(str_addr, InStrRev(str_addr, ":") + 2, Len(str_addr) - InStrRev(str_addr, "$") + 1)
End If
obj_xls.columns.AutoFit
obj_xls.Rows.AutoFit
obj_xls.Range("A1").select
obj_xls.ActiveWorkbook.save
Set obj_xls = Nothing
Set objPivotCache = Nothing
Set cmd_sp = Nothing
Set rst_temp = Nothing
Exit_reformat_fund_totals:
DoCmd.Hourglass False
DoCmd.Echo True
Exit Function
Err_reformat_fund_totals:
DoCmd.Hourglass False
DoCmd.Echo True
If Err.Number = 2302 Then
str_sql = "A file is already open and must be closed before this data can be exported."
MsgBox str_sql, vbCritical, "SIC"
End If
MsgBox Err.description
Resume Exit_reformat_fund_totals
End Function
