Code:
Private Sub cmdExcelPivotTable_Click()
On Error Resume Next
Dim sExcelFile As String
'Dim oApp As Object
'Dim oPC As Object
'Dim oPT As Object
'Dim oWT As Object
'Dim oWS As Object
Dim oApp As Excel.Application
Dim oPC As Excel.PivotCache
Dim oPT As Excel.PivotTable
Dim oWT As Excel.Workbook
Dim oWS As Excel.Worksheet
Dim oNm As Excel.Name
Dim PivotCache As Object
Dim PF As Object
Dim PI As Object
Dim lastRow As Long, lastColumn As Long
Dim lStartOfDataList As Long
Dim lEndOfDataList As Long
Dim sColumns As String, sRows As String, sPages As String
Dim sColumn() As String, sRow() As String, sPage() As String
Dim sArrayColumns() As String, sArrayRows() As String, sArrayPages() As String
Dim i As Integer, sPivotField As String
Dim rs As Recordset, sNamedRange As String
Dim vaTmp() As String
Dim sSheet As String, sTL_Address As String, sBR_address As String
Dim t, prm As DAO.Parameter, qdf As DAO.QueryDef, db As DAO.Database, X As Integer, lRecords As Long
'first lets save the settings
cmdSavePivotSettings_Click
Application.Echo False
sNamedRange = Nz(Me.tNamedRange, Replace(Replace(Replace(Replace(Replace(Replace(Me.txtPivotSource, " ", "_"), "-", "_"), ".", "_"), ",", "_"), ";", "_"), "\", "_"))
If Me.grpPivotAction = 1 Then
'create new Excelfile every time
If IsNull(Me.tExcelFileName) Then
'sExcelFile = GetSaveFile(Me.txtPivotSource) '& ".xls")
sExcelFile = vcGetFileNameExcel(Me.txtPivotSource & ".xlsx")
Else
sExcelFile = Me.tExcelFileName
End If
If sExcelFile = "" Then
Application.Echo True
Exit Sub
End If
'DoCmd.OutputTo acOutputQuery, Me.txtPivotSource, acFormatXLS, sExcelFile, True
Kill sExcelFile 're-create new Excelfile every time
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, Me.txtPivotSource, sExcelFile, True, sNamedRange
Set oApp = CreateObject("Excel.Application")
With oApp
On Error GoTo 0
.Visible = True
.Workbooks.Open sExcelFile
Set oWT = .ActiveWorkbook
Set oWS = oWT.ActiveSheet
.ScreenUpdating = False
.DisplayAlerts = False
'now to autofit columns
lStartOfDataList = 1
lastRow = oWS.Range("A" & oWS.Rows.Count).End(-4162).Row 'xlUp
lEndOfDataList = lastRow
lastColumn = oWS.Cells(lStartOfDataList, oWS.Columns.Count).End(-4159).Column 'xlToLeft
oWS.Range(oWS.Cells(1, 1), oWS.Cells(lastRow, lastColumn)).Select
.Selection.WrapText = False
oWS.Range(oWS.Cells(1, 1), oWS.Cells(lastRow, lastColumn)).Columns.AutoFit
oWS.Range("A1").Select
oWS.Name = "ISP Pivot Table Data"
'now lets move to Sheet 1 and create the pivot table to analyze
'Define input area and set up a Pivot Cache
'("A" & lStartOfDataList & ":F" & lEndOfDatList - 1))
oWT.Worksheets.Add(Before:=oWT.Worksheets(1)).Name = "ISP Pivot Table Analysis"
'Set oPC = oWT.PivotCaches.Add(SourceType:=1, _
SourceData:=oWS.Range(oWS.Cells(lStartOfDataList, 1), oWS.Cells(lEndOfDataList, lastColumn))) '1=xlDatabase
Set oPC = oWT.PivotCaches.Add(SourceType:=1, SourceData:=oWS.Range(sNamedRange)) '1=xlDatabase
Set oPT = oPC.CreatePivotTable(TableDestination:=oWT.Worksheets("ISP Pivot Table Analysis").Cells(7, 2), _
TableName:="pvtISP")
'fill the columns array
sColumns = ""
For i = 0 To 4
If Nz(Me.Controls("Column" & i + 1), "") <> "" Then sColumns = sColumns & "," & Me.Controls("Column" & i + 1)
Next i
sColumns = IIf(Left(sColumns, 1) = ",", Mid(sColumns, 2), sColumns)
If sColumns = "" Then GoTo PVT_ROW_ARRAY
sColumn = Split(sColumns, ",")
ReDim sArrayColumns(UBound(sColumn))
For i = 0 To UBound(sColumn)
sArrayColumns(i) = sColumn(i)
Next i
oPT.AddFields ColumnFields:=sArrayColumns, AddToTable:=True
PVT_ROW_ARRAY:
'fill the rows array
sRows = ""
For i = 0 To 4
If Nz(Me.Controls("Row" & i + 1), "") <> "" Then sRows = sRows & "," & Me.Controls("Row" & i + 1)
Next i
sRows = IIf(Left(sRows, 1) = ",", Mid(sRows, 2), sRows)
If sRows = "" Then GoTo PVT_PAGE_ARRAY
sRow = Split(sRows, ",")
ReDim sArrayRows(UBound(sRow))
For i = 0 To UBound(sRow)
sArrayRows(i) = sRow(i)
Next i
oPT.AddFields RowFields:=sArrayRows, AddToTable:=True
PVT_PAGE_ARRAY:
' 'fill the Pages array
sPages = ""
For i = 0 To 2
If Nz(Me.Controls("Page" & i + 1), "") <> "" Then sPages = sPages & "," & Me.Controls("Page" & i + 1)
Next i
sPages = IIf(Left(sPages, 1) = ",", Mid(sPages, 2), sPages)
If sPages = "" Then GoTo PVT_ADD_DATA_FIELDS
sPage = Split(sPages, ",")
ReDim sArrayPages(UBound(sPage))
For i = 0 To UBound(sPage)
sArrayPages(i) = sPage(i)
Next i
oPT.AddFields PageFields:=sArrayPages, AddToTable:=True
PVT_ADD_DATA_FIELDS:
'now lets add the data fields
For i = 0 To 4
If Nz(Me.Controls("Data" & i + 1), "") <> "" Then
sPivotField = Me.Controls("Data" & i + 1)
oPT.AddDataField oPT.PivotFields(sPivotField), Nz(Me.Controls("DATA_Caption" & i + 1), Me.Controls("DATA_Metric" & i + 1).Column(1) & " of " & sPivotField), CLng(Me.Controls("DATA_Metric" & i + 1))
End If
Next i
'show details
If Me.grpDetails = 2 Then
With oWT.Worksheets("ISP Pivot Table Analysis").PivotTables(1).TableRange1
.Cells(.Rows.Count, .Columns.Count).ShowDetail = True
End With
End If
For Each PivotCache In oWT.PivotCaches
PivotCache.Refresh
Next
'lets do the header
oWT.Worksheets("ISP Pivot Table Analysis").Range("A1") = "Selected query:"
oWT.Worksheets("ISP Pivot Table Analysis").Range("A1").Font.Name = "Calibri"
oWT.Worksheets("ISP Pivot Table Analysis").Range("A1").Font.Size = 12
oWT.Worksheets("ISP Pivot Table Analysis").Range("A1").Font.Color = 16744448
oWT.Worksheets("ISP Pivot Table Analysis").Range("A2") = Me.txtPivotSource
oWT.Worksheets("ISP Pivot Table Analysis").Select
.ScreenUpdating = True
.DisplayAlerts = True
End With
Else
'use existing Excel template - export data and refresh pivot tables
sExcelFile = Nz(Me.tExcelTemplate, "")
If sExcelFile = "" Then
MsgBox "The Excel file template is missing!", vbCritical, "No template selected"
Me.tExcelTemplate.SetFocus
Exit Sub
End If
If Dir(sExcelFile) = "" Then
MsgBox "The Excel file template name/path is wrong!", vbCritical, "No template with selected name exists"
Me.tExcelTemplate.SetFocus
Exit Sub
End If
Set db = CurrentDb
Set qdf = db.QueryDefs(Me.txtPivotSource)
For Each prm In qdf.Parameters
prm.Value = Eval(prm.Name)
Next prm
Set rs = qdf.OpenRecordset()
ReDim vaTmp(rs.Fields.Count)
For X = 0 To rs.Fields.Count - 1
vaTmp(X) = rs.Fields(X).Name
Next
rs.MoveLast
lRecords = rs.RecordCount
rs.MoveFirst
Set oApp = CreateObject("Excel.Application")
With oApp
On Error GoTo 0
.Visible = True
.Workbooks.Open sExcelFile
Set oWT = .ActiveWorkbook
.ScreenUpdating = False
.DisplayAlerts = False
t = Me.tNamedRange
Set oNm = oWT.Names(t)
sSheet = Mid(oNm.RefersTo, 3, InStr(oNm.RefersTo, "!") - 4)
Set oWS = oWT.Worksheets(sSheet)
oWS.Range(t).Clear
oWS.Range(t).Cells(1, 1).Resize(1, rs.Fields.Count) = vaTmp
oWS.Range(t).Cells(2, 1).CopyFromRecordset rs
'need to resize the named range to be equal to the used range
lastRow = lRecords '
lastColumn = X - 1 'x count started from 0
' Dim y, w
' y = oWS.Range(t).Cells(1, 1).Column + lastColumn
' w = oWS.Range(t).Cells(1, 1).Row + lastRow
' sBR_address = oWS.Cells(oWS.Range(t).Cells(1, 1).Column + lastColumn, oWS.Range(t).Cells(1, 1).Row + lastRow).Address
' sTL_Address = oWS.Range(t).Cells(1, 1).Address
' oWT.Names.Add t, RefersTo:="=" & sSheet & "!" & sTL_Address & ":" & sBR_address
oWS.Range(oWS.Range(t).Cells(1, 1), oWS.Cells(oWS.Range(t).Cells(1, 1).Row + lastRow, oWS.Range(t).Cells(1, 1).Column + lastColumn)).Name = t
'refresh pivot table(s)
For Each PivotCache In oWT.PivotCaches
PivotCache.Refresh
Next
oWT.Worksheets(1).Select
Set rs = Nothing
Set prm = Nothing
Set qdf = Nothing
Set db = Nothing
End With
End If
Application.Echo True
oApp.ScreenUpdating = True
oApp.DisplayAlerts = True
oApp.Visible = True
Set oApp = Nothing
End Sub