vba - 在 Excel 2010 中从 VBA 刷新 power pivot 的简单方法？

Question

我想执行以下等效操作:

• Power Pivot > 表格 > 全部更新
• 数据透视表工具 > 数据 > 全部刷新

使用 VBA。所有表格都是文件中包含的 Excel 表格。

有没有在 Excel 2010 中执行此操作的简单方法？

Answer 1

对于数据透视表更新，此代码将顺利运行:

ThisWorkbook.RefreshAll

或者，如果您的 Excel 版本太旧:

Dim Sheet as WorkSheet, _
    Pivot as PivotTable

For Each Sheet in ThisWorkbook.WorkSheets
    For Each Pivot in Sheet.PivotTables
        Pivot.RefreshTable
        Pivot.Update
    Next Sheet 
Next Pivot 

---

---

在 Excel 2013 中，要刷新 PowerPivot，只需一行 ActiveWorkbook.Model.Refresh。

在 Excel 2010 中，...要复杂得多! Here is the general code made by Tom Gleeson :

' ==================================================
' 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