一、VBA和PowerQuery的优缺点

VBA和PowerQuery都是Excel中内置^[1]的编程功能。VBA的优点在于灵活性极强，缺点在于无法进行多线程运算；而PowerQuery的优点在于按照SQL的逻辑进行的设计，因而天然地就支持“多线程”运算（更准确地讲可以视作向量运算）。为何不把二者结合起来？这样可以将开发效率和运行效率同时提高！

二、如何利用VBA操纵PowerQuery

常用的方式是将PowerQuery的查询加载到某个Sheet中的Table/Range（在PowerQuery看来是Table，在VBA看来是Range），然后通过某种方式操纵PowerQuery的刷新动作。下面讲的内容均是如何利用VBA来刷新某个连接到PowerQuery的Table/Range。

1、基本操作

刷新单个Range

Range("Rng1").ListObject.QueryTable.Refresh BackgroundQuery:=False
'Rng是待刷新Range的Name属性

刷新所有Range

ThisWorkbook.RefreshAll

2、更精细的操控——等刷新完毕后执行下一句

在使用ListObject.QueryTable.Refresh时，VBA无法等待某个Range刷新完毕后再执行下一句。

a、粗暴的处理

如果编写的程序比较简单，不需要指定刷新哪几个Range，则可以利用RefreshAll+CalculateUntilAsyncQueriesDone来实现。比如：

ThisWorkBook.RefreshAll
Application.CalculateUntilAsyncQueriesDone
'等待所有Range刷新完后再执行下一句
MsgBox "完成！"

这样，VBA会等待所有Range刷新完后再执行下一句。但是这种用法比较简单粗暴，在实践中遇到更复杂的情况时，就无法派上用场，因此一般不会用它的。

b、精细的处理

通过本人在StackOverflow上查找，发现不仅ListObject.QueryTable.Refresh可以刷新PowerQuery加载到的Range，.OLEDBConnection.Refresh也可以（不明觉厉，哈哈），而且当把它的BackgroundQuery属性设置成False时，可以让当前的刷新完成后，再执行VBA中的下一句。利用这个特性，下面这个sub就可以实现等待刷新的功能：

Sub RefreshSheet(RngName)
'RngName是String，是待刷新的Range的Name属性值
    With ThisWorkbook.Connections("查询 - " & RngName).OLEDBConnection
        .BackgroundQuery = False
        .Refresh
    End With
End Sub

3、性能优化——同时刷新某几张表

当对于性能要求不高的时候，可以循环用上面的RefreshSheet这个Sub，在代码上做到简洁，但是这样就浪费掉了PowerQuery中的一个优秀的功能——异步刷新。所谓异步刷新，就是指充分利用缓存和多线程等机制，使得同时刷新多个Range要远快于分别顺次刷新这些Range。

在不使用VBA的时候，最常见的方式就是点击“全部刷新”，但是这样不能指定只刷新某几个Range。而若使用VBA来实现同时只刷新某几个Range的效果，则需要费一定力气。

a、主要原理

将BackgroundQuery设置为True，然后利用Range("Rng1").ListObject.QueryTable.Refresh BackgroundQuery:=True或将OLEDBConnection中的BackgroundQuery设置为True后再.Refresh来启动异步刷新。

b、主要问题

如何等待这些Range刷新完毕，再执行VBA的下一句？这就需要找到可以等Range刷新的VBA命令。遗憾的是，并没有直接等待Range刷新完毕的语句。Application.CalculateUntilAsyncQueriesDone会让VBA卡死，DoEvents或Sleep则会因为二者均可“阻止”PowerQuery将刷新后的表加载至Sheet中，而导致PowerQuery始终无法完成刷新，最终陷入死循环。但是，当我在调试VBA的时候发现，一旦终止VBA语句，则待刷新的Range会立刻加载到Sheet里。也就是说，DoEvents、Sleep只能是在VBA语句里等，而不能在其以外的范围内等。因此要想出一招既等又不等的方式。

c、解决办法

基本思路是，首先找一个生僻字符（比如我找的字是“飝”），令待刷新的Range的.Cells(1,1).Value等于这个生僻字，第二步是开启异步刷新并令VBA结束运行，第三步当生僻字因为PowerQuery的刷新完毕而消失时，利用Workbook_Change来重新触发VBA语句，检测这些表是否均完成了刷新（即生僻字“飝”是否都消失了），第四步是若生僻字都消失了，则执行下一句，否则结束VBA的运行，等待PowerQuery继续刷新。

但是在具落笔时，遇到了一些客观的情况。

功能实现上的有：

• 怎么让VBA结束运行后记得住哪些表进行了刷新、后续要执行哪个sub？

  创建一个class，然后让这个class在模块内声名为Public，将刷新的表的名称、后续执行的sub的名称作为该class的一个属性装进去。

• 怎么让VBA去执行下一个sub？

  利用Application.Run，尽管它有一些不方便。

性能优化上的有：

• 如何减少Workbook_Change事件触发带来的运算量？

  在上述创建的class中，加一个属性，表示目前异步刷新的状态，如果不在进行异步刷新的话，则结束Worksheet_Change这个sub。

• 如何减少异步刷新的内存及CPU占用，从而进一步强化性能？

  在检测到某个Range已经加载完毕后，立刻将“它”的BackgroundQuery属性设为False。因为若仍然保留True，则似乎会占用很大的内存和CPU，就像打开了允许数据后台刷新的功能一样；及时设置为False后，内存和CPU的占用会大大改善。

d、具体代码

将以下代码打包了一个类：ayncRefreshThr

Private isRefreshing As Boolean, asyncRefreshRanges As Object
Private tStart, tEnd As Double, sucMacro As String, asyncN As Long
Private durationPmpt As Boolean

Private Sub Class_Initialize()
  isRefreshing = False '表示异步刷新的状态
  Set asyncRefreshRanges = CreateObject("Scripting.Dictionary")
  '记录待刷新的Range。当处于异步刷新时，若检测到发生变化的Range不在其中，则进行下一步操作。
  asyncRefreshRanges.RemoveAll
  tStart = 0: tEnd = 0 '利用Timer记录起止时刻
  sucMacro = "" '记录异步刷新完成后应执行哪个sub
  durationPmpt = False '异步刷新完成时是否提示用了多长时间
  asyncN = 0 '一共有几个Range待刷新
End Sub

Sub asyncRefresh(rngArr, Optional macroStr = "", Optional durationPrompt = False, Optional singleThdebug As Boolean = False)
' rngArr：是Array，其中每个元素均是String，是待刷新表的Name
' macroStr是异步刷新完成后要执行哪一个sub的名称，是String类型。为空时代表着不执行，不空时，格式是“模块名.sub名”
' singleThdebug用于控制是否使用异步刷新的方式批量刷新一批Range。仅在调试中使用。
Dim i As Integer, tmpstr1, tmpstr2 As String
  If singleThdebug Then
  '一个一个Range地刷，不采用异步刷新。此处仅供调试用。
      If Len(macroStr) <> 0 Then sucMacro = ThisWorkbook.Name & "!" & CStr(macroStr) 'Application.Run其实还要在前面补上工作簿的名称，但是因为肯定是自己内部引用，所以在设计函数时省略，并于此处自动补充上。
      For Each itm In rngArr
          RefreshSheet itm
      Next itm
      If Len(sucMacro) <> 0 Then Application.Run sucMacro
  Else '异步刷新的开始
      tStart = Timer
      durationPmpt = CBool(durationPrompt)
      If Len(macroStr) <> 0 Then sucMacro = ThisWorkbook.Name & "!" & CStr(macroStr)
          For i = 1 To arrLen(rngArr)
          tmpstr1 = CStr(rngArr(LBound(rngArr) + i - 1))
          If Not asyncRefreshRanges.exists(tmpstr1) Then
              asyncRefreshRanges.Add tmpstr1, ""
          End If
      Next i

      '打上生僻字标记
      For Each itm In asyncRefreshRanges.keys
          Range(itm).Cells(1, 1).Value = "飝"
      Next itm

      isRefreshing = True
      For Each itm In asyncRefreshRanges.keys
          Range(itm).ListObject.QueryTable.Refresh BackgroundQuery:=True
      Next itm
      asyncN = asyncRefreshRanges.Count
      Application.StatusBar = "正在异步刷新（0/" & asyncN & "）：" & Join(asyncRefreshRanges.keys, "、")
  End If
End Sub

Sub checkStatus() '让Workbook_Change事件触发这个方法
  If isRefreshing Then
      If asyncRefreshOver() Then
          isRefreshing = False: tEnd = Timer
          If durationPmpt Then MsgBox "刷新用时：" & Format(tEnd - tStart, "0.00秒"), vbInformation, "异步刷新完成"
          If Len(sucMacro) <> 0 Then Application.Run sucMacro
      End If
  End If
End Sub

Private Function asyncRefreshOver(Optional statusBarStyle = "live") As Boolean
'statusBarStyle：状态栏展示的样式，和程序主体无关。
Dim n As Integer, isOver As Boolean
  If isRefreshing = False Then
      asyncRefreshOver = True
  Else
      isOver = True
      Select Case statusBarStyle
          Case "process"
              For Each itm In asyncRefreshRanges.keys
                  n = 0 '待累加量，表示有多少个Range完成了刷新
                  If asyncRefreshRanges.Item(itm) = "ok" Then
                      'isOver = isOver And True
                      n = n + 1
                  ElseIf Range(itm).Cells(1, 1) = "飝" Then
                      isOver = False
                  Else
                      asyncRefreshRanges.Item(itm) = "ok"
                      Range(itm).ListObject.QueryTable.BackgroundQuery = False '关闭后台刷新，减少系统资源占用
                      n = n + 1
                  End If
              Next itm
              Application.StatusBar = "正在异步刷新（" & n & "/" & asyncN & "）：" & Join(asyncRefreshRanges.keys, "、")
          Case "live"
              For Each itm In asyncRefreshRanges.keys
                  If Range(itm).Cells(1, 1) = "飝" Then
                      isOver = False
                  Else
                      asyncRefreshRanges.Remove (itm)
                      Range(itm).ListObject.QueryTable.BackgroundQuery = False
                  End If
              Next itm
              Application.StatusBar = "正在异步刷新（" & (asyncN - asyncRefreshRanges.Count) & "/" & asyncN & "）：" & Join(asyncRefreshRanges.keys, "、")
          Case Else
              isOver = True
      End Select

      If isOver Then
          'MsgBox "刷新完毕！"
          isRefreshing = False
          asyncRefreshRanges.RemoveAll
          Application.StatusBar = False
      End If
      asyncRefreshOver = isOver
  End If
End Function

Private Function arrLen(arr) As Long
  arrLen = UBound(arr) - LBound(arr) + 1
End Function

Private Sub RefreshSheet(RngName) 'RngName是String，是待刷新的Range的Name属性值
  With ThisWorkbook.Connections("查询 - " & RngName).OLEDBConnection
      .BackgroundQuery = False
      .Refresh
  End With
End Sub

在Workbook中设置触发事件：

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    aRefreshT1.checkStatus
End Sub

在一般的模块中写：

Public aRefreshT1 As New ayncRefreshThr

Sub RefreshSheets(rngArr, Optional macro = "", Optional durationPrompt As Boolean = False)
    aRefreshT1.asyncRefresh rngArr, macro, durationPrompt
    ' rngArr：是Array，其中每个元素是String，表示待刷新Range的Name
    ' macro：完成刷新后执行的本Workbook内的sub，不能带参数。格式写成“模块名.sub名”
    ' durationPrompt：是否提示异地刷新完成时间
End Sub

1. 自Office 2016起PowerQuery才完全嵌入Excel，在2013版时需要单独安装插件，在更早的版本则无法支持。 ↩