Automating PowerPivot Refresh operation from VBA | Tom Gleeson

This article explains how to automate PowerPivot refresh in Excel 2010 and 2013 using VBA.

If Excel 2013

It's simple, VBA Object Model now supports Power Pivot, so just ...

ActiveWorkbook.Model.Refresh

... that's it!

For Excel 2010

It's a bit more complex:

The first thing to do is get an ADODB connection to the local embedded Power Pivot engine. I tried using the connection string details used by the Excel PowerPivot model connection (see under Data->Connections) but couldn't get past an authentication error. There may be a way around this, but I decided to short circuit the problem by using the Excel Object Model to directly fetch the already established connection's ADODB handle via...

ActiveWorkbook.Connections("PowerPivot Data").OLEDBConnection.ADOConnection

One problem with this method is that when a workbook is first opened the default PowerPivot Data connection will not yet be established, needs something like a PivotTable refresh or a Cube formula call to fire it up. But again this can be automated.

Next step is to issue an XMLA command like the one in this post (no need for the CubeID property, but if you want, you can specify it as "Model" or "Sandbox" depending on the version of PowerPivot; “Model” seems to be the new name of the cube in the latest version).

But how to get DatabaseID? Use a ...

select distinct object_parent_path from $system.discover_object_activity

...DMVcall to get a list of database objects and parse out the DatabaseID from an object like so...

myMachine\LocalCube.Databases.CBBB19B2CD9B4017A8A0

...where myMachine is your PC's name and the DatabaseID is this case is CBBB19B2CD9B4017A8A0.

The DatabaseID can also be seen in the un-zipped Excel file but it appears to change when the workbook is loaded so will need to be refreshed each time.

The important bit of the XMLA command is this...

<Type>ProcessFull</Type>

Having issued the command, the PowerPivot model will refresh all its external connections and rebuild the Model (aka Sandbox) cube. Linked Excel tables however, appear not to be affected by this.

The workbooks pivot tables still require to be refreshed separately, but this too can be automated via an ActiveWorkbook.Connections("PowerPivot Data").Refresh or individual PivotTable refreshes.

Ideally the PowerPivot window should be closed during the refresh.

Errors

Error -2147467259 (80004005) is an ADO error which when raised by the Refresh code can be caused by a number of issues. The most likely causes include:

No PowerPivot backed PivotTable created in Workbook (hence no connection to tap into) - solution 1st create a PivotTable based on the PP model.
Authentication problems with accessing source data - solution make sure you have access and that all credentials are stored correctly within the connection i.e. prompts for username/passwords are not handled.
A timeout - increase timeout length or set to 0 (no timeout).

If the above appears to be not the problem then see this article for a guide to getting back more information from ADO about the specific error.

Need help?

If you need help with this,Power Pivot data model design, DAX, or general automation, I'm for hire, contact me here.

Full Source Code

' ==================================================
' Test PowerPivot Refresh
' Developed By: Tom  http://www.tomgleeson.ie
' Based on ideas by Marco Rosso, Chris Webb and Mark Stacey
' Dedicated to Bob Phillips a most impatient man ...
' Sep 2011
'
' =======================================================

Option Explicit

#If Win64 Then

Public Declare PtrSafe Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)

#Else

Public Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)

#End If


Sub Refresh()
    Dim lDatabaseID As String
    Dim lDimensionID As String
    Dim lTable As String
    Dim RS As Object 'ADODB.Recordset
    Dim cnn As Object 'ADODB.Connection
    Dim mdx As String
    Dim xmla As String
    Dim cnnName As String
    Dim lSPID As String
    Dim lArray
    Dim i As Long


    On Error Resume Next
        ' For Excel 2013+ use connection name e.g. "Text InvoiceHeaders"
        ' Fr Excel 2010 use table name e.g. "InvoiceHeaders"
        lTable = [TableToRefresh]
    On Error GoTo 0
    ' if Excel 2013 onwards: use Connections or Model refresh option via Object Model
    If Application.Version() > 14 Then
        ' "wake up" model
        ActiveWorkbook.Model.Initialize
        If lTable <> "" Then
            ActiveWorkbook.Connections(lTable).Refresh
        Else
            ActiveWorkbook.Model.Refresh
        End If
        ' For Excel 2013 that's all folks.
        Exit Sub
    End If


    cnnName = "PowerPivot Data"
    '1st "wake up" default PowerPivot Connection
    ActiveWorkbook.Connections(cnnName).Refresh
    '2nd fetch that ADO connection
    Set cnn = ActiveWorkbook.Connections(cnnName).OLEDBConnection.ADOConnection
    Set RS = CreateObject("ADODB.Recordset")
    ' then fetch the dimension ID if a single table specified
    ' FIX: need to exclude all rows where 2nd char = "$"
    mdx = "select table_id,rows_count from $System.discover_storage_tables where not mid(table_id,2,1) = '$' and not dimension_name = table_id and dimension_name='<<<<TABLE_ID>>>>'"
    If lTable <> "" Then
        mdx = Replace(mdx, "<<<<TABLE_ID>>>>", lTable)
        RS.Open mdx, cnn
        lDimensionID = fetchDIM(RS)
        RS.Close
        If lDimensionID = "" Then
            lDimensionID = lTable
        End If
    End If

    ' then fetch a valid SPID for this workbook
    mdx = "select session_spid from $system.discover_sessions"
    RS.Open mdx, cnn
    lSPID = fetchSPID(RS)
    If lSPID = "" Then
            MsgBox "Something wrong - cannot locate a SPID !"
            Exit Sub
    End If
    RS.Close
    'Next get the current DatabaseID - changes each time the workbook is loaded
    mdx = "select distinct object_parent_path,object_id from $system.discover_object_activity"
    RS.Open mdx, cnn
    lArray = Split(lSPID, ",")
    For i = 0 To UBound(lArray)
        lDatabaseID = fetchDatabaseID(RS, CStr(lArray(i)))
        If lDatabaseID <> "" Then
            Exit For
        End If
    Next i
    If lDatabaseID = "" Then
            MsgBox "Something wrong - cannot locate DatabaseID - refesh PowerPivot connnection and try again !"
            Exit Sub
    End If
    RS.Close
    'msgbox lDatabaseID
    If doXMLA(cnn, lDatabaseID, lDimensionID) = "OK" Then
        Sleep 1000
        ' refresh connections and any related PTs ...
        ActiveWorkbook.Connections(cnnName).Refresh
    End If


End Sub

Private Function doXMLA(cnn, databaseID As String, Optional dimensionID As String = "", Optional timeout As Long = 30)
Dim xmla As String
Dim lRet
Dim comm As Object ' ADODB.Command

    ' The XMLA Batch request
    If dimensionID = "" Then
     xmla = "<Batch xmlns=""http://schemas.microsoft.com/analysisservices/2003/engine""><Parallel><Process xmlns:xsd=""http://www.w3.org/2001/XMLSchema"" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" xmlns:ddl2=""http://schemas.microsoft.com/analysisservices/2003/engine/2"" xmlns:ddl2_2=""http://schemas.microsoft.com/analysisservices/2003/engine/2/2"" xmlns:ddl100_100=""http://schemas.microsoft.com/analysisservices/2008/engine/100/100""><Object><DatabaseID><<<DatabaseID>>></DatabaseID></Object><Type>ProcessFull</Type><WriteBackTableCreation>UseExisting</WriteBackTableCreation></Process></Parallel></Batch>"
     xmla = Replace(xmla, "<<<DatabaseID>>>", databaseID)
    Else
     xmla = "<Batch xmlns=""http://schemas.microsoft.com/analysisservices/2003/engine""><Parallel><Process xmlns:xsd=""http://www.w3.org/2001/XMLSchema"" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" xmlns:ddl2=""http://schemas.microsoft.com/analysisservices/2003/engine/2"" xmlns:ddl2_2=""http://schemas.microsoft.com/analysisservices/2003/engine/2/2"" xmlns:ddl100_100=""http://schemas.microsoft.com/analysisservices/2008/engine/100/100""><Object><DatabaseID><<<DatabaseID>>></DatabaseID><DimensionID><<<DimensionID>>></DimensionID></Object><Type>ProcessFull</Type><WriteBackTableCreation>UseExisting</WriteBackTableCreation></Process></Parallel></Batch>"
     xmla = Replace(xmla, "<<<DatabaseID>>>", databaseID)
     xmla = Replace(xmla, "<<<DimensionID>>>", dimensionID)
    End If

    Set comm = CreateObject("ADODB.command")
    comm.CommandTimeout = timeout
    comm.CommandText = xmla
    Set comm.ActiveConnection = cnn
    comm.Execute
    ' Make the request
    'On Error Resume Next - comment out on error as most are not trappable within VBA !!!
    'lRet = cnn.Execute(xmla)
    'If Err Then Stop
    doXMLA = "OK"

End Function
Private Function fetchDatabaseID(ByVal inRS As Object, SPID As String) As String
Dim i As Long
Dim useThis As Boolean
Dim lArray
Dim lSID As String

lSID = "Global.Sessions.SPID_" & SPID
Do While Not inRS.EOF
  'Debug.Print inRS.Fields(0)
  If CStr(inRS.Fields(0)) = lSID Then
    lArray = Split(CStr(inRS.Fields(1)), ".")
    On Error Resume Next
    If UBound(lArray) > 2 Then
        ' find database permission activity for this SPID to fetch DatabaseID
        If lArray(0) = "Permissions" And lArray(2) = "Databases" Then
              fetchDatabaseID = CStr(lArray(3))
              Exit Function
        End If
    End If
  End If
  On Error GoTo 0
  inRS.MoveNext
Loop
inRS.MoveFirst
fetchDatabaseID = ""
End Function

Private Function fetchSPID(ByVal inRS As Object) As String
Dim lSPID As String

lSPID = ""
Do While Not inRS.EOF
    If lSPID = "" Then
        lSPID = CStr(inRS.Fields(0).Value)
    Else
        lSPID = lSPID & "," & CStr(inRS.Fields(0).Value)
    End If
    inRS.MoveNext
Loop
fetchSPID = lSPID

End Function

Private Function fetchDIM(ByVal inRS As Object) As String
Dim lArray
Dim lSID As String

If Not inRS.EOF Then
  fetchDIM = inRS.Fields(0)
Else
  fetchDIM = ""
End If
End Function