Building Excel 2007 Pivot Tables connected to cubes using VBA

Hi.

I recently embarked on the idea of building a pivot table connected to a cube. It seemed so simple !? Just build a MDX query, pass it to Excel, and voila!!! OOPS!!! Excel cannot take MDX queries. If you want to add rows, columns and measures, you have to do it it manually. And Then I started searching for the how to... Would you believe it... There are myriads of examples, and yet each one of them are only people who recorded a macro, then pasted the code. It helps to point you in the right direction, but I kept hitting stumpling blocks (as opposed to a stumbling block - a stumpling block is where you just don't know anymore... you are stumped).

So here is some code I developed. It builds the connection, clears the existing tables, and recreates a pivottable dynamically. The key though, is that I added 2 mods (AddFieldToTable and AddFilterToTable), that you just pass params to, and it will take care of the rest. Write once, use many times!!!

It may be easier to step through the code, than trying to explain it.

Please take a look at it,and comment if this helps...

Regards,

Zanoni...




Option Explicit
'An enum for the type of filter to be applied (one item or multiple items
Private Enum xlFilterType
SingleItemFilter = 0
MultipleItemFilter = 1
End Enum

'An enum to indicate if an item must be part of the list of visible items, or if it is an item to be removed
Private Enum xlFilterVisibility
Visible = 0
Hidden = 1
End Enum

'Collection to store the filter values
Private mColFilterFields As Collection

'An instance of an array for the values
Private MultipleFilterFields() As String


'==========================================================================================
'Main sub to build the Pivot Table
'==========================================================================================
'Date By Action
'==========================================================================================
'6 Jan 2010 Zanoni Labuschagne Created
'==========================================================================================
Public Sub GenerateResultSet()
On Error Resume Next
Dim strPartner, strYear, strScheme As String
Dim DestSheet As Excel.Worksheet
Dim DestRange As Excel.Range
Dim myPVT As Excel.PivotTable

'Set the sheet where the pivottable will be placed
Set DestSheet = ThisWorkbook.Worksheets("Sheet2")

'Set the range on the sheet where the pivottable will be placed
Set DestRange = DestSheet.Cells(10, 1)

Set mColFilterFields = New Collection

'Get the values for the filters
strPartner = DestSheet.Cells(1, 2).Value
strYear = DestSheet.Cells(2, 2).Value
strScheme = DestSheet.Cells(4, 2)

'Remove existing pivottables from the sheet
ClearExistingPivotTables DestSheet
DestRange.Select

'Build the connection to the cube
CreateConnection DestRange, "MyTable"

Set myPVT = DestSheet.PivotTables("MyTable")

'To make it look neater, hide the sheet while building
DestSheet.Visible = xlSheetHidden

'Hide the field list
ThisWorkbook.ShowPivotTableFieldList = False

'For performance, stop auto updating
myPVT.ManualUpdate = True

'Add the pivottable fields & filters
AddFieldToPivot myPVT, "Dimension Number1", "Attribute number 1", xlPageField
AddFilterToField myPVT, "Dimension Number1", "Attribute number 1", xlPageField, SingleItemFilter, "Some Value"

'Add another Dim Field
AddFieldToPivot myPVT, "Dimension Number 2", "Attribute number 2", xlPageField
AddFilterToField myPVT, "Dimension Number 2", "Attribute number 2", xlPageField, SingleItemFilter, "Some other Value"

'Add another Dim Field, and do a multiple filter
AddFieldToPivot myPVT, "Dimension Number 3", "Attribute number 3", xlRowField, True

'Hide e.g. the Unknown member
AddFilterToField myPVT, "Dimension Number 3", "Attribute number 3", xlRowField, MultipleItemFilter, "Unknown", Hidden

'Hide e.g. a blank member
AddFilterToField myPVT, "Dimension Number 3", "Attribute number 3", xlRowField, MultipleItemFilter, "", Hidden

'Hide e.g. SomeFunnyMember
AddFilterToField myPVT, "Dimension Number 3", "Attribute number 3", xlRowField, MultipleItemFilter, "SomeFunnyMember", Hidden

'Add some measures
AddFieldToPivot myPVT, "Measures", "[Measure 1]", xlDataField
AddFieldToPivot myPVT, "Measures", "[Measure 2]", xlDataField
AddFieldToPivot myPVT, "Measures", "[Measure 3]", xlDataField

'Update the table
myPVT.Update

'Show the sheet
DestSheet.Visible = xlSheetVisible

'Set the sheet focus
DestSheet.Select
End Sub


'==========================================================================================
'Adds a field to the PivotTable
'Parameters:
' PivotTableObject - A reference to the pivottable
' Dimension - Name of the dimension being added (For a measure, use "Measures"
' DimAttribute - Name of the attribute being added
' FieldType - Will the field be pleaced in the page area, Row, column, or value
' SuppressSubTotal - Must the subtotal be shown or hidden
'==========================================================================================
'Date By Action
'==========================================================================================
'6 Jan 2010 Zanoni Labuschagne Created
'==========================================================================================
Private Sub AddFieldToPivot(ByRef PivotTableObject As PivotTable, ByVal Dimension As String, ByVal DimAttribute As String, ByVal FieldType As XlPivotFieldOrientation, Optional ByVal SuppressSubTotal As Boolean)
On Error GoTo AddFieldError
Dim Hierarchy, FilterHierarchy As String

'Format and build the full hierarchy name
Dimension = "[" & Replace(Replace(Dimension, "]", ""), "[", "") & "]"
DimAttribute = "[" & Replace(Replace(DimAttribute, "]", ""), "[", "") & "]"
Hierarchy = Dimension & "." & DimAttribute
FilterHierarchy = Hierarchy & "." & DimAttribute


Select Case FieldType
'Add rows/Columns
Case xlColumnField, xlRowField
With PivotTableObject.CubeFields(Hierarchy)
.Orientation = FieldType
Select Case FieldType
Case xlColumnField
.Position = PivotTableObject.ColumnFields.Count + 1
Case xlRowField
.Position = PivotTableObject.RowFields.Count + 1
End Select
End With

If SuppressSubTotal Then
PivotTableObject.PivotFields(FilterHierarchy).Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
End If

'Add Page Fields
Case xlPageField
With PivotTableObject.CubeFields(Hierarchy)
.Orientation = xlPageField
.Position = PivotTableObject.PageFields.Count + 1
End With

'Add measures
Case xlDataField
PivotTableObject.AddDataField PivotTableObject.CubeFields(Hierarchy)
End Select
Exit Sub

AddFieldError:
Select Case Err.Number
Case 9
MsgBox "Could not find the attribute " & DimAttribute & ".", vbCritical + vbOKOnly
Exit Sub
Case Else
MsgBox Err.Description, vbCritical + vbOKOnly
Resume Next
End Select
End Sub

'==========================================================================================
'Adds a filter to the PivotTable
'Parameters:
' PivotTableObject - A reference to the pivottable
' Dimension - Name of the dimension being added (For a measure, use "Measures"
' DimAttribute - Name of the attribute being added
' FieldType - Will the field be pleaced in the page area, Row, column, or value
' FilterType - is it one item, or multiple items
' Style - Must the filter remove an item from a full list, or add it to an emplty list
'==========================================================================================
'Date By Action
'==========================================================================================
'6 Jan 2010 Zanoni Labuschagne Created
'==========================================================================================

Private Sub AddFilterToField(ByRef PivotTableObject As PivotTable, ByVal Dimension As String, ByVal DimAttribute As String, ByVal FieldType As XlPivotFieldOrientation, ByVal FilterType As xlFilterType, ByVal FilterValue As String, Optional Style As xlFilterVisibility)
On Error GoTo AddFilterError
Dim Hierarchy, FilterHierarchy, FilterMember As String
Dim MultiFilterList() As String
'Format and build the full hierarchy name
Dimension = "[" & Replace(Replace(Dimension, "]", ""), "[", "") & "]"
DimAttribute = "[" & Replace(Replace(DimAttribute, "]", ""), "[", "") & "]"
Hierarchy = Dimension & "." & DimAttribute
FilterHierarchy = Hierarchy & "." & DimAttribute
FilterMember = Hierarchy & ".&[" & FilterValue & "]"

Select Case FilterType
Case SingleItemFilter
PivotTableObject.CubeFields(Hierarchy).EnableMultiplePageItems = False
PivotTableObject.PivotFields(FilterHierarchy).CurrentPageName = FilterMember

Case MultipleItemFilter
PivotTableObject.CubeFields(Hierarchy).EnableMultiplePageItems = True

MultipleFilterFields = GetFieldArrayFromCollection(Hierarchy)
ReDim Preserve MultipleFilterFields(UBound(MultipleFilterFields) + 1)
MultipleFilterFields(UBound(MultipleFilterFields)) = FilterMember
If Style = Visible Then
PivotTableObject.CubeFields(Hierarchy).IncludeNewItemsInFilter = False
PivotTableObject.CubeFields(Hierarchy).PivotFields(FilterHierarchy).VisibleItemsList = MultipleFilterFields
Else
PivotTableObject.CubeFields(Hierarchy).IncludeNewItemsInFilter = True
PivotTableObject.CubeFields(Hierarchy).PivotFields(FilterHierarchy).HiddenItemsList = MultipleFilterFields
End If
WriteFieldArrayToCollection Hierarchy, MultipleFilterFields()
End Select

Exit Sub

AddFilterError:
Select Case Err.Number
Case 9 ' Array not yet initialised
ReDim MultipleFilterFields(0)
Resume
Case Else
MsgBox "Could not add a filter to " & Dimension & " for value " & FilterMember & Chr(13) & Chr(13) & Err.Description, vbCritical + vbOKOnly
Exit Sub
End Select

End Sub

'==========================================================================================
'Creates the Excel Connection to the Cube
'Parameters:
' DestinationRange - The Excel Range where the cube must be placed
' TableName - The reference name you want to give the pivottable
'==========================================================================================
'Date By Action
'==========================================================================================
'6 Jan 2010 Zanoni Labuschagne Created
'==========================================================================================
Private Sub CreateConnection(ByRef DestinationRange As Range, ByVal TableName As String)
On Error Resume Next
'TODO: Add Variables instead of hardcoding
Dim ConnectionName, ConnectionString, ConnectionCommand As String

ConnectionName = "MyConnection"
ConnectionString = "OLEDB;Provider=MSOLAP.4;Integrated Security=SSPI;Persist Security Info=True;Data Source=YourServerName;Initial Catalog=YourASDatabase"
ConnectionCommand = "YourDefaultCube"

ThisWorkbook.Connections(ConnectionName).Delete
ThisWorkbook.Connections.Add ConnectionName, "Connection used to connect to HIP DW GP Cube", ConnectionString, ConnectionCommand, 1

ThisWorkbook.PivotCaches.Create(xlExternal, ThisWorkbook.Connections(ConnectionName), xlPivotTableVersion12).CreatePivotTable DestinationRange, TableName, xlPivotTableVersion12

End Sub
'==========================================================================================
'Clears all Pivot tables from the sheet
'Parameters:
' MySheet - The reference to the sheet to clear
'======================================e====================================================
'Date By Action
'==========================================================================================
'6 Jan 2010 Zanoni Labuschagne Created
'==========================================================================================
Private Sub ClearExistingPivotTables(ByRef mySheet As Worksheet)
Dim myPVT As PivotTable

For Each myPVT In mySheet.PivotTables
myPVT.PivotSelect "", xlDataAndLabel, True
Selection.ClearContents
Next myPVT
End Sub
'==========================================================================================
'Gets an array of filter fields from a collection
'Parameters:
' Hierarchy - The key to the item to be retrieved
'======================================e====================================================
'Date By Action
'==========================================================================================
'6 Jan 2010 Zanoni Labuschagne Created
'==========================================================================================
Private Function GetFieldArrayFromCollection(ByVal Hierarchy As String) As String()
On Error Resume Next
GetFieldArrayFromCollection = mColFilterFields(Hierarchy)
End Function


'==========================================================================================
'Writes an array of filter fields into a collection
'Parameters:
' Hierarchy - The key to the item to be retrieved
' FieldArray - The updated array to be written back into the collection
'======================================e====================================================
'Date By Action
'==========================================================================================
'6 Jan 2010 Zanoni Labuschagne Created
'==========================================================================================
Private Sub WriteFieldArrayToCollection(ByVal Hierarchy As String, FieldArray() As String)
On Error Resume Next
mColFilterFields.Remove Hierarchy
mColFilterFields.Add FieldArray(), Hierarchy
End Sub

Dynamics Integration Manager Niggles

Being a newbie to GP IM (yet another ETL tool), I recently battled to get journals through to GP, and here is what I learned:

• If you ever have an issue where GP doesn't return your columns, check your query... I had one calling a stored proc, and in the proc, had multiple statements... when running the proc in SSMS, it works, but in GP IM it doesn't... At the top of the proc include:
  "Set Nocount On"
  
  It turns out, it only runs up to the result it gets, then stops. This statement means don't return any row counts.
  


• Make sure that, under Destination Mapping -> Entries-> Options, you have use "Use Source Recordset" for Recordset. If you don't, the batches will be created but won't have any transactions in them.
  


• GP's ODBC connection can't have ANSI NULL translations. I had a "where" clause in the stored proc source stripping rows with no account number, but the rows were still being returned!?. I had to find another way to remove these rows (I joined to another source table to filter empty rows out)
  

Excel 2007 Hangs when opening a .XLSM workbook

I recently had a massive amount of scripting in a workbook. I saved it, but when I tried reopening it, it froze. I almost cried.

First, try repoening it while pressing Shift (this disables the macros)

If no success

To fix it:
* Click the Start Menu then select Run. Type "regedit" (without the quotation marks) into the Run dialog box and click OK.
* Select My Computer at the top of the Registry tree in the left pane of the Registry Editor.
* Then backup the registry by selecting File - Export from the Registry Editor menu, entering a name for the registry backup file and clicking OK.
* Navigate the the following registry key: HKEY_CURRENT_USER\Software\Microsoft\Office\12.0\Excel\Security
* With the "Security" key highlighted, select Edit - New - DWORD Value from the Registry Editor menu.
* Type "ExcelBypassEncryptedMacroScan" (without the quotation marks) for the new value name and hit enter
* Then double-click on the newly added value and change the DWORD Value from 0 to 1 and then click OK.
* Exit the Registry Editor and the exit and restart Excel 2007 for the change to take affect.

Forwarding emails from Exchange to an External address

Okay, so this may be simple for an exchange / AD guru, but myself, I had to set this up recently, and it was actually very painless...

1. In AD, create a contact for the address you want to send to
2. In Exchange (on SBS2003), open the account on which you want to apply the forwarding
3. In Exchange General, click on Delivery Options
4. Select "Forward To"
5. Select the new contact
6. choose whether the emails must be sent to both mailboxes, or only the external

As easy as that... not that a DBB developer should have to know it, but hey, it cvan't hurt to have abit of knowledge of other products?

Metadata errors when trying to access a cube via SSMS

I recently found a cube that you could not query. No MDX, No SSMS feedback, nothing... (Yes, I had permissions to access it)

Short solution

Moved the XML files in the cubes data folder to a backup folder somewhere else (you can delete, but you may need these files later). Then, I restarted SSAS service, reprocessed the cuby, and voila!!!

Moving a user-profile in windows XP

We recently had a situation, where SSIS caching a lot of data in the TEMP folder of the user profile. The default drive only had about 2 GB available, while the E-Drive had about 100GB. We couldn't find a setting to force SSIS to use the E_Drive, so we moved the profile to the E-drive. This is how to move it...

* Log in as an admin account BUT NOT THE PROFILE WE WANT TO MOVE!!! ( Make sure the user is also not logged in on the machine)
* Right-click "My Computer" -> Properties -> Advanced -> User Profiles -> Settings -> Move profile
* We moved the profile to the E-Drive ("E:\Profiles\MyUserName")
* Run REGEDIT
* Go to HKEY_LOCAL_MACHINE -> Software -> Microsoft -> Windows NT -> Current Version -> Profile List
* Ignore the folders with the "short names"
* Look at each folder, and look at the value for ProfileImagePath to see the user name
* Change the path to the folder where you copied the profile to (e.g. ("E:\Profiles\MyUserName")
* Close Regedit, and log back in with the user

When we reran the packages, lo and behold, the E-Drive started getting hit. Problem solved

Splitting number of seconds into time

I recently helped on a workflow BI system, and most of the measures were durations, e.g. a workflow took 2000 seconds to do. Problem is, you can't tell an end-user a step took 2000 seconds - it makes no sense. Rather, they want to know it took 33 minutes, 20 seconds. So, heres a UDF to do just that...

if Object_ID('fn_SplitSecondsIntoTime') is not null
drop function dbo.fn_SplitSecondsIntoTime
go
create function dbo.fn_SplitSecondsIntoTime(@intSeconds int)
/************************************************************
Splits a certain amount of seconds into its time components
************************************************************/
Returns @SplitTime Table
(
Days int
,Hours int
,Minutes int
,Seconds int
,LongOutputString varchar(200)
,ShortOutputString varchar(200)
)
as
begin

Declare @intRemainder int
,@intDays int
,@intHours int
,@intMinutes int

Select @intRemainder = 0

Select @intDays = @intSeconds / (60*60*24)
Select @intRemainder = @intSeconds % (60*60*24)

Select @intHours = @intRemainder / (60*60)
select @intRemainder = @intRemainder % (60*60)

Select @intMinutes = @intRemainder / 60
Select @intRemainder = @intRemainder % 60

Select @intSeconds = @intRemainder

Insert into @SplitTime
Select @intDays as Days
,@intHours as Hours
,@intMinutes as Minutes
,@intSeconds as Seconds
,convert(varchar(10),@intDays)
+ ' days, '
+ convert(varchar(10),@intHours)
+ ' hours, '
+ convert(varchar(10),@intMinutes)
+ ' minutes, '
+ convert(varchar(10),@intSeconds)
+ ' seconds'
,case
when @intDays > 0
then convert(varchar(10),@intDays) + 'd'
else ''
end
+ case
when @intHours > 0
then convert(varchar(10),@intHours) + 'h'
else ''
end
+ case
when @intMinutes > 0
then convert(varchar(10),@intMinutes) + 'm'
else ''
end
+ case
when @intSeconds > 0
then convert(varchar(10),@intSeconds) + 's'
else ''
end

Return

End
go

-- USAGE EXAMPLE
select * from dbo.fn_SplitSecondsIntoTime(2000)