Option Explicit
Function UpdatePivotFromQuery()
'---Uses query to aggregate records from different periods
'--update Unique Period PivotItems
UpdateDummyPivot
'--update Pivot based on Selected Periods
UpdatePivotBasedOnPeriods
End Function
Function UpdatePivotBasedOnPeriods()
'--Uses query that aggregates date for the Period(s)
' selected. Writes results to a range
' that is used as Pivot datasource
Dim sSql As String, sWhereFilter As String
Dim PT As PivotTable, PTDummy As PivotTable
With Sheets("Pivot")
Set PT = .PivotTables("PivotTable1")
Set PTDummy = .PivotTables("DummyForFilter")
End With
'--read current filter selections from drop down list
sWhereFilter = MakeFilterClause( _
PTDummy.PivotFields("Period"))
'--make query based on filter list
sSql = Join$(Array( _
"SELECT Activity, Cluster, Comp, Dept,", _
"Employee, Status, Year,", _
"SUM(DaysAbsence) AS SumOfDaysAbsence,", _
"SUM(DaysActual) AS SumOfDaysActual,", _
"SUM(DaysInjury) AS SumOfDaysInjury,", _
"SUM(DaysLeaves) AS SumOfDaysLeaves,", _
"SUM(DaysOpen) AS SumOfDaysOpen", _
"FROM [Raw Data$]", _
sWhereFilter, _
"GROUP BY Activity, Cluster, Comp, Dept,", _
"Employee, Status, Year" _
), vbCr)
'--copy recordset to range, update name
With Sheets("QueryResults")
.Range("C2:N" & .Rows.Count).Clear
Call OpenAndCopyFromRecordsetThisWB(sSql, _
.Range("C2"))
.Range("C1:N" & .Cells(.Rows.Count, _
"C").End(xlUp).Row).Name = "PivotDataFromQuery"
End With
'--refresh pivot
PT.PivotCache.Refresh
End Function
Function UpdateDummyPivot()
'--Uses query and writes Unique Periods to a range
' that is used as Pivot datasource
Dim sSql As String
sSql = Join$(Array( _
"SELECT DISTINCT Period", _
"FROM [Raw Data$]", _
"WHERE Period <> '(blank)' " _
), vbCr)
'--copy recordset to range, update name
With Sheets("QueryResults")
.Range("A2:A" & .Rows.Count).Clear
Call OpenAndCopyFromRecordsetThisWB(sSql, _
.Range("A2"))
.Range("A1:A" & .Cells(.Rows.Count, _
"A").End(xlUp).Row).Name = "UniquePeriods"
End With
Sheets("Pivot").PivotTables("DummyForFilter") _
.PivotCache.Refresh
End Function
Function OpenAndCopyFromRecordsetThisWB(sSql As String, _
rDestination As Range)
'---Runs query copies resulting rst to rDestination
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Set cnn = New ADODB.Connection
With cnn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Extended Properties").Value = "Excel 8.0"
.Open ActiveWorkbook.FullName
End With
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseServer
rst.Open Source:=sSql, _
ActiveConnection:=cnn, _
CursorType:=adOpenStatic, _
LockType:=adLockReadOnly, _
Options:=adCmdText
rDestination.CopyFromRecordset rst
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
End Function
Function MakeFilterClause(PF As PivotField) As String
'--reads selected items from report filter PF and
' makes WHERE clause that can be used in query
' returns "" if (All) selected
Dim sPage As String
Dim i As Long, lCountSelected As Long
Dim vSelected As Variant
With PF
vSelected = GetFilterList(PF)
For i = LBound(vSelected) To UBound(vSelected)
MakeFilterClause = MakeFilterClause & ",'" _
& vSelected(i) & "'"
Next i
MakeFilterClause = _
"WHERE Period IN (" & Mid(MakeFilterClause, 2) & ")"
End With
End Function
Function GetFilterList(PF As PivotField) As Variant
'--returns a Variant array of selected items in PivotField
Dim sPage As String
Dim i As Long, lCountSelected As Long, lCount As Long
Dim vSelected As Variant
Dim pi As PivotItem
With PF
lCount = .PivotItems.Count
ReDim vSelected(1 To lCount)
If .EnableMultiplePageItems Then
For i = 1 To lCount
If .PivotItems(i).RecordCount Then
If .PivotItems(i).Visible Then
lCountSelected = 1 + lCountSelected
vSelected(lCountSelected) = .PivotItems(i)
End If
End If
Next i
ReDim Preserve vSelected(1 To lCountSelected)
Else
sPage = .CurrentPage
If sPage = "(All)" Then
vSelected = GetPivotItemList(PF)
Else
ReDim vSelected(1 To 1)
vSelected(1) = sPage
End If
End If
End With
GetFilterList = vSelected
End Function
Function GetPivotItemList(PF As PivotField) As Variant
'--returns a Variant array of all PivotItems
' from report filter PF
Dim i As Long, lCount As Long, lCountExists As Long
Dim vSelected As Variant
With PF
lCount = .PivotItems.Count
ReDim vSelected(1 To lCount)
For i = 1 To lCount
If .PivotItems(i).RecordCount Then
lCountExists = 1 + lCountExists
vSelected(lCountExists) = .PivotItems(i)
End If
Next i
If lCountExists <> lCount Then _
ReDim Preserve vSelected(1 To lCountExists)
End With
GetPivotItemList = vSelected
End Function
