mod_off_ExcelPivotTables (from acc).bas

Attribute VB_Name = "mod_off_ExcelPivotTables"
' mod_off_ExcelPivotTables

' miscellaneous Pivot Table manipulation routines
'  130912.AMG  converted from mod_exc_PivotTables to work from any office programme
'  130910.AMG  added error handling
'  130909.AMG  refactored more functions in for simpler calling code, and added formatting features
'  130906.AMG  created

' NB if this project is being used outside Excel it requires REFERENCES to execute:
' Microsoft Office Excel 12         c:\Program Files\Microsoft Office\Office12\ExCEL.EXE

Option Explicit

' error handling tag
Const cStrModuleName As String = "mod_off_ExcelPivotTables"


Public Enum eNumberFormat
    [_First] = 1
    General = 1
    DecimalNumber
    IntegerNumber
    CurrencyValue
    [_Last]
End Enum

Function FirstWorksheetWholeTableAddress _
(wbk As Excel.Workbook _
) As String
    FirstWorksheetWholeTableAddress = "'" & wbk.Worksheets(1).Name & "'!" & wbk.Worksheets(1).UsedRange.Address
End Function

Function PivotCacheAdd _
(wbk As Excel.Workbook _
, strDataRange As String _
) As Excel.PivotCache
''' standard procedure error handler begin initialise 130813.AMG '''
ErrorAlerts False
On Error GoTo ErrorHandler
Dim strErrorObject, strProcedureName As String
strProcedureName = "PivotCacheAdd"
strErrorObject = CStr(strDataRange)
''' standard procedure error handler end initialise '''

    ' Create a PivotCache for as many PivotTables as required
    
    ' Don't bother declaring internally as the function is just a 1-liner
    ' Dim cch As Excel.PivotCache
    Set PivotCacheAdd = wbk.PivotCaches.Add( _
        SourceType:=xlDatabase, _
        SourceData:=strDataRange)

''' standard procedure error handler begin terminate 130813.AMG '''
Proc_Exit:
ErrorAlerts True
Exit Function
ErrorHandler:
ErrorAlerts True
HandleErrorWithMessage "Error trying to '" & cStrModuleName & "." & strProcedureName & "' (" & _
    strErrorObject & ") " & vbCrLf & vbCrLf & _
    "Error " & Err.Number & vbCrLf & """" & Err.Description & """"
Resume Proc_Exit
''' standard procedure error handler end terminate '''

End Function

Function PivotTableAddOnNewSheet _
(ByRef wbk As Excel.Workbook _
, ByRef cch As Excel.PivotCache _
, ByVal strPivotSheetName As String _
, ByVal lIndex As Long _
, Optional lRow As Long = 3 _
) As Excel.PivotTable

''' standard procedure error handler begin initialise 130910.AMG '''
ErrorAlerts False
On Error GoTo ErrorHandler
Dim strErrorObject As String
Const cStrProcedureName As String = "PivotTableAddOnNewSheet"
strErrorObject = strPivotSheetName
''' standard procedure error handler end initialise '''

    Dim sht As Worksheet
    Dim pvt As PivotTable
    
    ' create the sheet and the table
    Set sht = wbk.Sheets.Add
    sht.Name = strPivotSheetName
    
    ' position the sheet
    ' if index parameter is less then 1 then it is relative to LAST existing worksheet...
    Dim lAbsolute As Long
    If lIndex > 0 Then
        lAbsolute = lIndex
    Else
        lAbsolute = wbk.Worksheets.Count + lIndex
    End If
    sht.Move after:=wbk.Worksheets(lAbsolute)
    
    ' create pivot
    Set pvt = cch.CreatePivotTable( _
        TableDestination:=wbk.Worksheets(strPivotSheetName).Cells(lRow, 1), _
        tablename:=strPivotSheetName)

    ' return object
    Set PivotTableAddOnNewSheet = pvt

''' standard procedure error handler begin terminate 130813.AMG '''
Proc_Exit:
ErrorAlerts True
Exit Function
ErrorHandler:
ErrorAlerts True
HandleErrorWithMessage "Error trying to '" & cStrModuleName & "." & cStrProcedureName & "' (" & _
    strErrorObject & ") " & vbCrLf & vbCrLf & _
    "Error " & Err.Number & vbCrLf & """" & Err.Description & """"
Resume Proc_Exit
''' standard procedure error handler end terminate '''
End Function


Function PivotHideValue _
(pvt As Object _
, strFieldName As String _
, strCheckValue As String _
) As Boolean
''' standard procedure error handler begin initialise 130910.AMG '''
ErrorAlerts False
On Error GoTo ErrorHandler
Dim strErrorObject As String
Const cStrProcedureName As String = "PivotHideValue"
strErrorObject = "Pivot: " & pvt.Name & " Field: " & strFieldName & " Value: " & strCheckValue
''' standard procedure error handler end initialise '''

    Dim i As Integer
    For i = 1 To pvt.PivotFields(strFieldName).PivotItems.Count
        If strCheckValue = pvt.PivotFields(strFieldName).PivotItems(i).Name Then
            pvt.PivotFields(strFieldName).PivotItems(strCheckValue).Visible = False
            Exit Function
        End If
    Next i
    ' if no such value is found, simply exit (rather than throw an error)

''' standard procedure error handler begin terminate 130813.AMG '''
Proc_Exit:
ErrorAlerts True
Exit Function
ErrorHandler:
ErrorAlerts True
HandleErrorWithMessage "Error trying to '" & cStrModuleName & "." & cStrProcedureName & "' (" & _
    strErrorObject & ") " & vbCrLf & vbCrLf & _
    "Error " & Err.Number & vbCrLf & """" & Err.Description & """"
Resume Proc_Exit
''' standard procedure error handler end terminate '''
End Function


Function PivotHideAllValuesExcept _
(pvt As PivotTable _
, strFieldName As String _
, strCheckValue As String _
)
''' standard procedure error handler begin initialise 130910.AMG '''
ErrorAlerts False
On Error GoTo ErrorHandler
Dim strErrorObject As String
Const cStrProcedureName As String = "PivotHideAllValuesExcept"
strErrorObject = "Pivot: " & pvt.Name & " Fields: " & strFieldName & " Value: " & strCheckValue
''' standard procedure error handler end initialise '''

'    Dim i As Integer
'    For i = 1 To pvt.PivotFields(strFieldName).PivotItems.Count
'        If strCheckValue = pvt.PivotFields(strFieldName).PivotItems(i).Name Then
'            pvt.PivotFields(strFieldName).PivotItems(strCheckValue).Visible = False
    
    Dim strFullCheck, strRootError As String
    Dim pi As PivotItem
    
    Const cStrDelim As String = ","
    ' strCheckValues is a comma delimited list, so make it easy to search by topping and tailing it
    strFullCheck = cStrDelim & strCheckValue & cStrDelim
    strRootError = strErrorObject
    For Each pi In pvt.PivotFields(strFieldName).PivotItems
        If InStr(strFullCheck, cStrDelim & pi.Name & cStrDelim) > 0 Then
            strErrorObject = strRootError & " setting " & pi.Name & " visible"
            pi.Visible = True
        Else
            strErrorObject = strRootError & " setting " & pi.Name & " invisible"
            pi.Visible = False
        End If
    Next
'    Next i
    ' if no such value is found, simply exit (rather than throw an error)
    
''' standard procedure error handler begin terminate 130813.AMG '''
Proc_Exit:
ErrorAlerts True
Exit Function
ErrorHandler:
ErrorAlerts True
HandleErrorWithMessage "Error trying to '" & cStrModuleName & "." & cStrProcedureName & "' (" & _
    strErrorObject & ") " & vbCrLf & vbCrLf & _
    "Error " & Err.Number & vbCrLf & """" & Err.Description & """"
Resume Proc_Exit
''' standard procedure error handler end terminate '''
End Function


Function PivotFieldFilter _
(fld As PivotField _
, Value _
) As Boolean
''' standard procedure error handler begin initialise 130910.AMG '''
ErrorAlerts False
On Error GoTo ErrorHandler
Dim strErrorObject As String
Const cStrProcedureName As String = "PivotFieldFilter"
strErrorObject = "PivotField: " & fld.Name & " Value: " & CStr(Value)
''' standard procedure error handler end initialise '''

    Excel.Application.ScreenUpdating = False
    With fld
        If .Orientation = xlPageField Then
            .CurrentPage = Value
        ElseIf .Orientation = xlRowField Or .Orientation = xlColumnField Then
            Dim i As Long
            On Error Resume Next ' Needed to avoid getting errors when manipulating fields that were deleted from the data source.
            ' Set first item to Visible to avoid getting no visible items while working
            .PivotItems(1).Visible = True
            For i = 2 To fld.PivotItems.Count
                If .PivotItems(i).Name = Value Then _
                    .PivotItems(i).Visible = True Else _
                    .PivotItems(i).Visible = False
            Next i
            If .PivotItems(1).Name = Value Then _
                .PivotItems(1).Visible = True Else _
                .PivotItems(1).Visible = False
        End If
    End With
    Excel.Application.ScreenUpdating = True

''' standard procedure error handler begin terminate 130813.AMG '''
Proc_Exit:
ErrorAlerts True
Exit Function
ErrorHandler:
ErrorAlerts True
HandleErrorWithMessage "Error trying to '" & cStrModuleName & "." & cStrProcedureName & "' (" & _
    strErrorObject & ") " & vbCrLf & vbCrLf & _
    "Error " & Err.Number & vbCrLf & """" & Err.Description & """"
Resume Proc_Exit
''' standard procedure error handler end terminate '''
End Function

'Function PivotFieldSetAsFirstRow _
'(fld As PivotField _
')
'''' standard procedure error handler begin initialise 130910.AMG '''
'ErrorAlerts False
'On Error GoTo ErrorHandler
'Dim strErrorObject As String
'Const cStrProcedureName As String = "PivotFieldFilter"
'strErrorObject = "PivotField: " & fld.Name & " Value: " & CStr(Value)
'''' standard procedure error handler end initialise '''
'
'    Excel.Application.ScreenUpdating = False
'    With fld
'        .Orientation = xlRowField
'        .Position = 1
'    End With
'    Excel.Application.ScreenUpdating = True
'
'''' standard procedure error handler begin terminate 130910.AMG '''
'Proc_Exit:
'ErrorAlerts True
'Exit Function
'ErrorHandler:
'ErrorAlerts True
'LogException "ERROR", "Trying to '" & cStrModuleName & "." & cStrProcedureName & "' (" & _
'strErrorObject & ") - " & "Error " & Err.Number & vbCrLf & " - """ & Err.Description & """"
'Err.Raise (Err.Number)
'Resume Proc_Exit
'''' standard procedure error handler end terminate '''
'End Function

Function PivotSetFieldAsFirstRow _
(pvt As PivotTable _
, strFieldName As String _
)
''' standard procedure error handler begin initialise 130910.AMG '''
ErrorAlerts False
On Error GoTo ErrorHandler
Dim strErrorObject As String
Const cStrProcedureName As String = "PivotSetFieldAsFirstRow"
strErrorObject = "Pivot: " & pvt.Name & " Field: " & strFieldName
''' standard procedure error handler end initialise '''

    Excel.Application.ScreenUpdating = False
    With pvt.PivotFields(strFieldName)
        .Orientation = xlRowField
        .Position = 1
    End With
    Excel.Application.ScreenUpdating = True

''' standard procedure error handler begin terminate 130813.AMG '''
Proc_Exit:
ErrorAlerts True
Exit Function
ErrorHandler:
ErrorAlerts True
HandleErrorWithMessage "Error trying to '" & cStrModuleName & "." & cStrProcedureName & "' (" & _
    strErrorObject & ") " & vbCrLf & vbCrLf & _
    "Error " & Err.Number & vbCrLf & """" & Err.Description & """"
Resume Proc_Exit
''' standard procedure error handler end terminate '''
End Function

Function PivotRowFieldFormat _
(ByRef pvt As PivotTable _
, ByVal strFieldName As String _
, ByVal lFormat As eNumberFormat _
)
''' standard procedure error handler begin initialise 130910.AMG '''
ErrorAlerts False
On Error GoTo ErrorHandler
Dim strErrorObject As String
Const cStrProcedureName As String = "PivotRowFieldFormat"
strErrorObject = "Pivot: " & pvt.Name & " Field: " & strFieldName
''' standard procedure error handler end initialise '''

    Excel.Application.ScreenUpdating = False
    Dim rng As Range
    Set rng = pvt.PivotFields(strFieldName).DataRange
    Select Case lFormat
        Case eNumberFormat.General:
            rng.NumberFormat = "General"
        Case eNumberFormat.DecimalNumber:
            rng.NumberFormat = "0.00"
        Case eNumberFormat.IntegerNumber:
           rng.NumberFormat = "0"
        Case eNumberFormat.CurrencyValue:
           rng.NumberFormat = "£#,##0"
        Case Else:
    End Select
    Excel.Application.ScreenUpdating = True

''' standard procedure error handler begin terminate 130813.AMG '''
Proc_Exit:
ErrorAlerts True
Exit Function
ErrorHandler:
ErrorAlerts True
HandleErrorWithMessage "Error trying to '" & cStrModuleName & "." & cStrProcedureName & "' (" & _
    strErrorObject & ") " & vbCrLf & vbCrLf & _
    "Error " & Err.Number & vbCrLf & """" & Err.Description & """"
Resume Proc_Exit
''' standard procedure error handler end terminate '''
End Function

' It was NOT valid to set number format for a rowfield :(
' "You can set the NumberFormat property only for a data field"
' quote > http://msdn.microsoft.com/en-us/library/office/bb237338(v=office.12).aspx
' so set it after the pivot is complete
'Function PivotSetFieldAsFirstRow _
'    (pvt As PivotTable _
'    , strFieldName As String _
'    , Optional ByVal lFormat As eNumberFormat _
'    )
'    Excel.Application.ScreenUpdating = False
'    With pvt.PivotFields(strFieldName)
'        .Orientation = xlRowField
'        .Position = 1
'        If Not IsMissing(lFormat) Then
'            Select Case lFormat
'                Case eNumberFormat.General:
'                    .NumberFormat = "General"
'                Case eNumberFormat.DecimalNumber:
'                    .NumberFormat = "0.00"
'                Case eNumberFormat.IntegerNumber:
'                   .NumberFormat = "0"
'                Case eNumberFormat.CurrencyValue:
'                   .NumberFormat = "£#,##0"
'                Case Else:
'            End Select
'        End If
'    End With
'    Excel.Application.ScreenUpdating = True
'End Function

Function PivotSetFieldAsTotal _
(ByRef pvt As PivotTable _
, ByVal strFieldName As String _
, Optional ByVal strCaption As String _
, Optional lFormat As eNumberFormat _
)
''' standard procedure error handler begin initialise 130910.AMG '''
ErrorAlerts False
On Error GoTo ErrorHandler
Dim strErrorObject As String
Const cStrProcedureName As String = "PivotSetFieldAsTotal"
strErrorObject = "Pivot: " & pvt.Name & " Field: " & strFieldName
''' standard procedure error handler end initialise '''


    Excel.Application.ScreenUpdating = False
        With pvt.PivotFields(strFieldName)
            .Orientation = xlDataField
            .Function = xlSum
            ' Summing the field changes the caption, so either set it as specified,
            ' or simply revert to the original field name
            If IsMissing(strCaption) Then
                .Caption = strFieldName
            Else
                .Caption = strCaption
            End If
            If Not IsMissing(lFormat) Then
                Select Case lFormat
                    Case eNumberFormat.General:
                        .NumberFormat = "General"
                    Case eNumberFormat.DecimalNumber:
                        .NumberFormat = "0.00"
                    Case eNumberFormat.IntegerNumber:
                       .NumberFormat = "0"
                    Case eNumberFormat.CurrencyValue:
                       .NumberFormat = "£#,##0"
                    Case Else:
                End Select
            End If
        End With
    Excel.Application.ScreenUpdating = True

''' standard procedure error handler begin terminate 130813.AMG '''
Proc_Exit:
ErrorAlerts True
Exit Function
ErrorHandler:
ErrorAlerts True
HandleErrorWithMessage "Error trying to '" & cStrModuleName & "." & cStrProcedureName & "' (" & _
    strErrorObject & ") " & vbCrLf & vbCrLf & _
    "Error " & Err.Number & vbCrLf & """" & Err.Description & """"
Resume Proc_Exit
''' standard procedure error handler end terminate '''
End Function

Function PivotShowSubtotalsOnFields _
(pvt As PivotTable _
, strFieldNames As String _
)
''' standard procedure error handler begin initialise 130910.AMG '''
ErrorAlerts False
On Error GoTo ErrorHandler
Dim strErrorObject As String
Const cStrProcedureName As String = "PivotShowSubtotalsOnFields"
strErrorObject = "Pivot: " & pvt.Name & " Fields: " & strFieldNames
''' standard procedure error handler end initialise '''

' accepts a comma-delimited list of Field Names
Const cStrDelim As String = ","
' all fields NOT in list will have their subtotals turned off
' e.g.
'     PivotShowSubtotalsOnFields pvt, "Phase,Class"

    Excel.Application.ScreenUpdating = False

    Dim fld As PivotField
    ' Make the delimited list easy to search by topping and tailing it
    Dim strDelimitedList, strNameWithDelims As String
    strDelimitedList = cStrDelim & strFieldNames & cStrDelim
    For Each fld In pvt.PivotFields
        strNameWithDelims = cStrDelim & fld.Name & cStrDelim
        If InStr(1, strNameWithDelims, strDelimitedList, vbTextCompare) Then
            fld.Subtotals(1) = True
        Else
            fld.Subtotals(1) = False
        End If
    Next fld
    Excel.Application.ScreenUpdating = True

''' standard procedure error handler begin terminate 130813.AMG '''
Proc_Exit:
ErrorAlerts True
Exit Function
ErrorHandler:
ErrorAlerts True
HandleErrorWithMessage "Error trying to '" & cStrModuleName & "." & cStrProcedureName & "' (" & _
    strErrorObject & ") " & vbCrLf & vbCrLf & _
    "Error " & Err.Number & vbCrLf & """" & Err.Description & """"
Resume Proc_Exit
''' standard procedure error handler end terminate '''
End Function


Function PivotColumnFormat _
(pvt As PivotTable _
, strFieldName As String _
, Optional dWidth As Double = 0 _
, Optional bWrap As Boolean = False _
)
''' standard procedure error handler begin initialise 130910.AMG '''
ErrorAlerts False
On Error GoTo ErrorHandler
Dim strErrorObject As String
Const cStrProcedureName As String = "PivotColumnFormat"
strErrorObject = "Pivot: " & pvt.Name & " Field: " & strFieldName
''' standard procedure error handler end initialise '''

    ' credit > useful visual reference for accessing parts of pivot table
    ' and how to use the valuable intersect
    ' http://peltiertech.com/WordPress/referencing-pivot-table-ranges-in-vba/

    Dim rng As Range
    Set rng = pvt.PivotFields(strFieldName).DataRange
    If dWidth <> 0 Then
        rng.ColumnWidth = dWidth
    End If
    If bWrap Then
        rng.WrapText = True
    End If

''' standard procedure error handler begin terminate 130813.AMG '''
Proc_Exit:
ErrorAlerts True
Exit Function
ErrorHandler:
ErrorAlerts True
HandleErrorWithMessage "Error trying to '" & cStrModuleName & "." & cStrProcedureName & "' (" & _
    strErrorObject & ") " & vbCrLf & vbCrLf & _
    "Error " & Err.Number & vbCrLf & """" & Err.Description & """"
Resume Proc_Exit
''' standard procedure error handler end terminate '''
End Function

Function PivotColumnsAutoFit _
(pvt As PivotTable _
, Optional strFieldNames As String _
)
''' standard procedure error handler begin initialise 130910.AMG '''
ErrorAlerts False
On Error GoTo ErrorHandler
Dim strErrorObject As String
Const cStrProcedureName As String = "PivotColumnsAutoFit"
strErrorObject = "Pivot: " & pvt.Name & " Fields: " & CStr(strFieldNames)
''' standard procedure error handler end initialise '''

' Sets Column Widths to AutoFit
' accepts a comma-delimited list of Field Names
Const cStrDelim As String = ","
' e.g.
'     PivotColumnsAutoFit pvt, "Phase,Class"
'
' If no names are specified then ALL columns will be autofitted

    Excel.Application.ScreenUpdating = False

    Dim bDoAllColumns As Boolean
    bDoAllColumns = IsMissing(strFieldNames)
    If Not bDoAllColumns Then
        bDoAllColumns = strFieldNames = ""
    End If

    If bDoAllColumns Then
        pvt.TableRange1.EntireColumn.AutoFit
    Else
        Dim fld As Excel.PivotField
        Dim strDelimitedList, strNameWithDelims As String
        ' Make the delimited list easy to search by topping and tailing it
        strDelimitedList = cStrDelim & strFieldNames & cStrDelim
        For Each fld In pvt.PivotFields
    
            ' we autofit the column is EITHER no list was specified...
            Dim bAutoFitThisColumn As Boolean
            bAutoFitThisColumn = IsMissing(strFieldNames)
            If Not bAutoFitThisColumn Then bAutoFitThisColumn = strFieldNames = ""
            ' OR if this field matches in the list
            If Not bAutoFitThisColumn Then
                strNameWithDelims = cStrDelim & fld.Name & cStrDelim
                bAutoFitThisColumn = InStr(1, strNameWithDelims, strDelimitedList, vbTextCompare)
            End If
    
            If bAutoFitThisColumn Then
                strErrorObject = fld.Name
                'if fld.Orientation
                fld.DataRange.EntireColumn.AutoFit
                'If Not fld.DataRange.Columns.AutoFit = True Then
                    'fld.DataRange.Columns.AutoFit
                'End If
            End If
        Next fld
    End If
    Excel.Application.ScreenUpdating = True

''' standard procedure error handler begin terminate 130813.AMG '''
Proc_Exit:
ErrorAlerts True
Exit Function
ErrorHandler:
ErrorAlerts True
HandleErrorWithMessage "Error trying to '" & cStrModuleName & "." & cStrProcedureName & "' (" & _
    strErrorObject & ") " & vbCrLf & vbCrLf & _
    "Error " & Err.Number & vbCrLf & """" & Err.Description & """"
Resume Proc_Exit
''' standard procedure error handler end terminate '''
End Function


Function PivotTableFormat( _
  pvt As Excel.PivotTable _
, Optional strTableStyle As String _
, Optional lThemeColor As Excel.XlThemeColor _
, Optional vTintAndShade As Variant _
)
''' standard procedure error handler begin initialise 130910.AMG '''
ErrorAlerts False
On Error GoTo ErrorHandler
Dim strErrorObject As String
Const cStrProcedureName As String = "PivotTableFormat"
strErrorObject = "Pivot: " & pvt.Name & " Style: " & strTableStyle
''' standard procedure error handler end initialise '''

    Dim sht As Excel.Worksheet
    Set sht = pvt.Parent

    If Not IsMissing(strTableStyle) Then
        pvt.TableStyle2 = strTableStyle
    End If
    If Not IsMissing(lThemeColor) Then
        sht.Tab.ThemeColor = lThemeColor
    End If
    If Not IsMissing(vTintAndShade) Then
        sht.Tab.TintAndShade = vTintAndShade
    End If
    ' move the selection off the pivot to hide the wizard
    ' may need to calc number of page fields to choose correct row
    sht.Cells(3, 1).Select

''' standard procedure error handler begin terminate 130813.AMG '''
Proc_Exit:
ErrorAlerts True
Exit Function
ErrorHandler:
ErrorAlerts True
HandleErrorWithMessage "Error trying to '" & cStrModuleName & "." & cStrProcedureName & "' (" & _
    strErrorObject & ") " & vbCrLf & vbCrLf & _
    "Error " & Err.Number & vbCrLf & """" & Err.Description & """"
Resume Proc_Exit
''' standard procedure error handler end terminate '''
End Function

Function PivotGrandTotals _
(pvt As Excel.PivotTable _
, bGrandTotalRow As Boolean _
)
    
    pvt.RowGrand = bGrandTotalRow

End Function