从 2010 年 Excel 刷新 VBA 的权力枢纽的简单方法？
Simple way to refresh power pivot from VBA in Excel 2010?
我想执行以下等效操作：
- Power Pivot > Tables > 全部更新
- 透视 Table 工具 > 数据 > 全部刷新
使用 VBA。所有表格都是文件中包含的 Excel 个表格。
在 Excel 2010 年有没有简单的方法可以做到这一点？
对于数据透视表更新，此代码将顺利运行：
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
2013年Excel刷新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
我想执行以下等效操作：
- Power Pivot > Tables > 全部更新
- 透视 Table 工具 > 数据 > 全部刷新
使用 VBA。所有表格都是文件中包含的 Excel 个表格。
在 Excel 2010 年有没有简单的方法可以做到这一点？
对于数据透视表更新，此代码将顺利运行：
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
2013年Excel刷新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