美文网首页
VBA小白入门之:在Excel中如何将VBA与PowerQuer

VBA小白入门之:在Excel中如何将VBA与PowerQuer

作者: 離塵真心 | 来源:发表于2022-05-17 03:32 被阅读0次

一、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版时需要单独安装插件,在更早的版本则无法支持。

相关文章

网友评论

      本文标题:VBA小白入门之:在Excel中如何将VBA与PowerQuer

      本文链接:https://www.haomeiwen.com/subject/keygurtx.html