[Excel][VBA] QueryTableの更新を待つ

0.README.md

[Excel][VBA] QueryTableの更新を待つ

かおてっく@Kao_Techさんのツイートで、ThisWorkbook.RefleshAllをすると（「バックグラウンドで更新」状態のクエリがある場合には）リフレッシュが完了する前にコードが先に進んでしまうという話題が出ていて、W.D.@WD4096さんが対策するコード例を出してくださったので、実際に試してみました。

ソースコード

テストコード中の

TargetTable.DataBodyRange.Rows.Delete

のような処理は、テーブルデータの変化がわかりやすいように検証用に入れてあるだけで、実際には不要です（ついでにいうとデータ行が存在しないとエラーが発生するので注意）

• CQtEvents: queryの終了を待つための共通クラスモジュール
• Mod_Test1: QueryTable.Refresh()でBackgroundQuery:=Falseを指定することにより完了を待つパターン
• Mod_Test2: CQtEventsのRefreshedプロパティをDo Loopで監視するパターン
• Mod_Test3: CQtEventsでAfterRefreshイベント発生時に指定した標準プロシージャを実行するパターン
• Mod_Test3All: CQtEventsでAfterRefreshイベント発生時に指定した標準プロシージャを実行するパターン(ブック内の全テーブル対象)
• Mod_TestAll: QueryTable.Refresh()でBackgroundQuery:=Falseを指定することにより完了を待つパターン(ブック内の全テーブル対象)
• Mod_TestConnections: ThisWorkbook.Connectionsを各々Refreshするパターン
• Mod_TestConnections2: ThisWorkbook.Connectionsを各々Refreshするパターン（BackgroundQuery=False設定版）
• Mod_TestConnections3: ThisWorkbook.Connectionsを各々Refreshするパターン（OLEDBConnection.BackgroundQuery=False設定版）

結果

Microsoft 365のExcel(32bit)とExcel 2010(32bit)+Power Query for Excelで、20000レコード強のCSVファイルをPower Queryで読み込んだテーブルにて試してみましたが、共に

• Test1（TestAll）とTest3（Test3All）は期待通りに動作する
• Test2は戻ってこない（Do Loopから抜けない）
• TestConnectionsだと更新完了が待てない（WorkbookConnection.Refreshにはオプションがなく、QueryTable.BackgroundQueryの状態依存）
  →QueryTable.BackgroundQueryの状態を保存して一旦Falseにしたあとで更新すれば大丈夫そう（TestConnections2）
  →（テーブルをいじる必要がなければ）OLEDBConnection.BackgroundQueryの状態保存→Falseに設定→Refresh→保存した値を戻すの方がシンプル（TestConnections3）
• 期待通りに動作したTest1とTest3では、クエリ完了時にテーブルも全て更新されている模様（→（「取り出し中」を監視して）テーブルの更新を待つ必要は、特にないのではないか？）

CQtEvents.vba

Option Explicit

Private WithEvents mQryTble As QueryTable
Private mRefreshed As Boolean
Private mCallback As String

Public Property Set QryTble(ByVal QryTable As QueryTable): Set mQryTble = QryTable: End Property
Public Property Get QryTble() As QueryTable: Set QryTble = mQryTble: End Property

Public Property Let Refreshed(ByVal paramRefreshed As Boolean): mRefreshed = paramRefreshed: End Property
Public Property Get Refreshed() As Boolean: Refreshed = mRefreshed: End Property

Public Property Let Callback(ByVal SpecifiedProcName): mCallback = SpecifiedProcName: End Property

Private Sub Class_Initialize()
    mRefreshed = False
End Sub

Private Sub mQryTble_BeforeRefresh(Cancel As Boolean)
    mRefreshed = False
    Debug.Print "*** mQryTble_BeforeRefresh(): Refreshed=" & Refreshed
End Sub

Private Sub mQryTble_AfterRefresh(ByVal Success As Boolean)
    mRefreshed = True
    Debug.Print "*** mQryTble_AfterRefresh(): Refreshed=" & Refreshed, "Success=" & Success
    If mCallback <> "" Then Application.Run mCallback, Success
End Sub

Mod_Test1.vba

Option Explicit

Sub TestRefresh1()
    Dim TargetTable As ListObject: Set TargetTable = ActiveSheet.ListObjects(1)
    TargetTable.DataBodyRange.Rows.Delete ' いったんテーブルのデータを全てクリア
    
    Dim TargetQueryTable As QueryTable: Set TargetQueryTable = TargetTable.QueryTable
    Dim classQtEvents As CQtEvents: Set classQtEvents = New CQtEvents
    Set classQtEvents.QryTble = TargetQueryTable
    
    Dim BeforeTime: BeforeTime = Timer
    Debug.Print "[Before] TargetQueryTable.Refreshing:" & TargetQueryTable.Refreshing, "Rows.Count: " & TargetTable.Range.Rows.Count
    
    classQtEvents.QryTble.Refresh BackgroundQuery:=False ' クエリ更新を待つ
    
    Debug.Print "[After]  TargetQueryTable.Refreshing:" & TargetQueryTable.Refreshing, "Rows.Count: " & TargetTable.Range.Rows.Count
    Debug.Print "[Completed] " & Format(Timer - BeforeTime, "00:00:00.000")
End Sub

Mod_Test2.vba

Option Explicit

Sub TestRefresh2()
    Dim TargetTable As ListObject: Set TargetTable = ActiveSheet.ListObjects(1)
    TargetTable.DataBodyRange.Rows.Delete ' いったんテーブルのデータを全てクリア
    
    Dim TargetQueryTable As QueryTable: Set TargetQueryTable = TargetTable.QueryTable
    Dim classQtEvents As CQtEvents: Set classQtEvents = New CQtEvents
    Set classQtEvents.QryTble = TargetQueryTable
    
    Dim BeforeTime: BeforeTime = Timer
    Debug.Print "[Before] TargetQueryTable.Refreshing:" & TargetQueryTable.Refreshing, "Rows.Count: " & TargetTable.Range.Rows.Count
'    classQtEvents.QryTble.Refresh BackgroundQuery:=True ' クエリ完了を待たない（バックグラウンドで行う）
    ThisWorkbook.RefreshAll ' すべて更新（クエリ完了を待たない）
    Debug.Print "[After]  TargetQueryTable.Refreshing:" & TargetQueryTable.Refreshing, "Rows.Count: " & TargetTable.Range.Rows.Count
    
    Dim Count As Long
    '再クエリまでループ
    ' 【TODO: ループから抜けられない】
    Do Until classQtEvents.Refreshed
'        Count = Count + 1
'        Debug.Print "Count: " & Count, TargetQueryTable.Refreshing
'        DoEvents
        Application.Wait [NOW()+"00:00:01"]
    Loop

    Debug.Print "[Completed] " & Format(Timer - BeforeTime, "00:00:00.000")
    Debug.Print "TargetQueryTable.Refreshing:" & TargetQueryTable.Refreshing, "Rows.Count: " & TargetTable.Range.Rows.Count
    Set classQtEvents = Nothing
End Sub

Mod_Test3.vba

Option Explicit

Private classQtEvents As CQtEvents
Private TargetTable As ListObject
Private BeforeTime

Sub TestRefresh3()
    Set TargetTable = ActiveSheet.ListObjects(1)
    TargetTable.DataBodyRange.Rows.Delete ' いったんテーブルのデータを全てクリア
    
    Dim TargetQueryTable As QueryTable: Set TargetQueryTable = TargetTable.QueryTable
    Set classQtEvents = New CQtEvents
    Set classQtEvents.QryTble = TargetQueryTable
    classQtEvents.Callback = "TestRefresh3_Callback" ' クエリ更新完了時に呼ばれるプロシージャを登録
    
    BeforeTime = Timer
    Debug.Print "[Before] TargetQueryTable.Refreshing:" & TargetQueryTable.Refreshing, "Rows.Count: " & TargetTable.Range.Rows.Count
'    classQtEvents.QryTble.Refresh BackgroundQuery:=True ' クエリ完了を待たない（バックグラウンドで行う）
    ThisWorkbook.RefreshAll ' すべて更新（クエリ完了を待たない）
    Debug.Print "[After]  TargetQueryTable.Refreshing:" & TargetQueryTable.Refreshing, "Rows.Count: " & TargetTable.Range.Rows.Count
End Sub

Sub TestRefresh3_Callback(Success As Boolean)
    Debug.Print "[Completed] " & Format(Timer - BeforeTime, "00:00:00.000"), "Success:" & Success
    Debug.Print "TargetQueryTable.Refreshing:" & TargetTable.QueryTable.Refreshing, "Rows.Count: " & TargetTable.Range.Rows.Count
    Set TargetTable = Nothing
    Set classQtEvents = Nothing
End Sub

Mod_Test3All.vba

Option Explicit

Private classQtEventsCol As Collection
Private TargetTableCol As Collection
Private BeforeTime
Private RemainCount As Long, SuccessCount As Long

Sub TestRefreshAll3()
    Set TargetTableCol = New Collection
    Set classQtEventsCol = New Collection
    Dim TargetSheet As Worksheet
    Dim TargetTable As ListObject
    Dim classQtEvents As CQtEvents
    For Each TargetSheet In ThisWorkbook.Worksheets
        For Each TargetTable In TargetSheet.ListObjects
            TargetTable.DataBodyRange.Rows.Delete ' いったんテーブルのデータを全てクリア
            TargetTableCol.Add TargetTable
            Set classQtEvents = New CQtEvents
            Set classQtEvents.QryTble = TargetTable.QueryTable
            classQtEvents.Callback = "TestRefreshAll3_Callback" ' クエリ更新完了時に呼ばれるプロシージャを登録
            classQtEventsCol.Add classQtEvents
        Next
    Next
    RemainCount = classQtEventsCol.Count: SuccessCount = 0
    BeforeTime = Timer
    ThisWorkbook.RefreshAll ' すべて更新（クエリ完了を待たない）
End Sub

Sub TestRefreshAll3_Callback(Success As Boolean)
    RemainCount = RemainCount - 1: If Success Then SuccessCount = SuccessCount + 1
    Debug.Print "(*) RemainCOunt=" & RemainCount
    If 0 < RemainCount Then Exit Sub
    Debug.Print "[Completed] " & Format(Timer - BeforeTime, "00:00:00.000"), "SuccessCount=" & SuccessCount
    Dim TargetTable As ListObject
    For Each TargetTable In TargetTableCol
        Debug.Print TargetTable.Name & ": TargetTable.QueryTable.Refreshing=" & TargetTable.QueryTable.Refreshing, "Rows.Count=" & TargetTable.Range.Rows.Count
    Next
    Set TargetTableCol = Nothing
    Set classQtEventsCol = Nothing
End Sub

Mod_TestAll.vba

Option Explicit

Sub TestRefreshAll()
    Dim TargetSheet As Worksheet
    Dim TargetTable As ListObject
    Dim Count As Long
    Dim BeforeTime: BeforeTime = Timer
    For Each TargetSheet In ThisWorkbook.Worksheets
        For Each TargetTable In TargetSheet.ListObjects
            Count = Count + 1
            TargetTable.DataBodyRange.Rows.Delete ' いったんテーブルのデータを全てクリア
            Debug.Print "No." & Count & ":" & TargetTable.Name
            Debug.Print "[Before] Rows.Count = " & TargetTable.Range.Rows.Count
            TargetTable.QueryTable.Refresh BackgroundQuery:=False  ' クエリ更新を待つ
            Debug.Print "[After]  Rows.Count = " & TargetTable.Range.Rows.Count
        Next
    Next
    Debug.Print "[Completed] " & Format(Timer - BeforeTime, "00:00:00.000")
End Sub

Mod_TestConnections.vba

Option Explicit

Sub TestRefreshAllConnections()
    Dim TargetSheet As Worksheet
    Dim TargetTable As ListObject
    Dim Count As Long
    Dim BeforeTime: BeforeTime = Timer
    For Each TargetSheet In ThisWorkbook.Worksheets
        For Each TargetTable In TargetSheet.ListObjects
            TargetTable.DataBodyRange.Rows.Delete ' いったんテーブルのデータを全てクリア
            Count = Count + 1: Debug.Print "No." & Count & ":" & TargetTable.Name
            Debug.Print "[Before] Rows.Count = " & TargetTable.Range.Rows.Count
        Next
    Next
    Dim WorkConnection As WorkbookConnection
    Count = 0
    For Each WorkConnection In ThisWorkbook.Connections
        Count = Count + 1: Debug.Print "Refresh Connection No." & Count
        WorkConnection.Refresh ' 更新は待たない（待つためのオプションもなし）
        ' ※各テーブルの「バックグラウンドで更新する」(QueryTable.BackgroundQuery)の状態に依存
    Next
    Count = 0
    For Each TargetSheet In ThisWorkbook.Worksheets
        For Each TargetTable In TargetSheet.ListObjects
            Count = Count + 1: Debug.Print "No." & Count & ":" & TargetTable.Name
            Debug.Print "[After]  Rows.Count = " & TargetTable.Range.Rows.Count
        Next
    Next
    Debug.Print "[Completed] " & Format(Timer - BeforeTime, "00:00:00.000") ' ※実際には更新完了していない
End Sub

Mod_TestConnections2.vba

Option Explicit

Sub TestRefreshAllConnections2()
    Dim WorkConnection As WorkbookConnection
    Dim WorkRange As Range
    Dim TargetSheet As Worksheet
    Dim TargetTable As ListObject
    Dim ConnCount As Long
    Dim TableCount As Long
    Dim TableList As Collection
    Dim SavedBackgroundQueryList As Collection
    Dim BeforeTime: BeforeTime = Timer
    For Each WorkConnection In ThisWorkbook.Connections
        ConnCount = ConnCount + 1: Debug.Print "Connection No." & ConnCount, "Ranges.Count=" & WorkConnection.Ranges.Count
        Set TableList = New Collection: Set SavedBackgroundQueryList = New Collection
        For Each WorkRange In WorkConnection.Ranges
            Set TargetSheet = WorkRange.Parent
            Set TargetTable = WorkRange.ListObject
            TableList.Add TargetTable
            Debug.Print "Table No." & TableList.Count, "TargetSheet:" & TargetSheet.Name, "TargetTable:" & TargetTable.Name
            SavedBackgroundQueryList.Add TargetTable.QueryTable.BackgroundQuery, Key:=TargetTable.Name ' BackgroundQueryの内容を退避
            TargetTable.QueryTable.BackgroundQuery = False ' BackgroundQueryを無効化
            On Error Resume Next: TargetTable.DataBodyRange.Rows.Delete: On Error GoTo 0 ' いったんテーブルのデータを全てクリア(動作検証用処理)
            Debug.Print "[Before] Rows.Count = " & TargetTable.Range.Rows.Count
        Next
        WorkConnection.Refresh ' 全ての関連テーブルのBackgroundQueryがFalseであれば更新完了されるまで待つはず
        For TableCount = 1 To TableList.Count
            Set TargetTable = TableList(TableCount)
            Debug.Print "Table No." & TableCount, "TargetTable:" & TargetTable.Name
            Debug.Print "[After]  Rows.Count = " & TargetTable.Range.Rows.Count
            TargetTable.QueryTable.BackgroundQuery = SavedBackgroundQueryList(TargetTable.Name)
        Next
        Debug.Print String(80, "-")
    Next
    Debug.Print "[Completed] " & Format(Timer - BeforeTime, "00:00:00.000")
End Sub

Mod_TestConnections3.vba

Option Explicit

Sub TestRefreshAllConnections3()
    Dim WorkConnection As WorkbookConnection
    Dim WorkRange As Range
    Dim ConnCount As Long
    Dim SavedBackgroundQuery As Boolean
    Dim BeforeTime: BeforeTime = Timer
    For Each WorkConnection In ThisWorkbook.Connections
        ConnCount = ConnCount + 1: Debug.Print "Connection No." & ConnCount, "Ranges.Count=" & WorkConnection.Ranges.Count
        On Error Resume Next ' .OLEDBConnectionが存在しない場合等を考慮してエラーを無視するようにしておく
        With WorkConnection.OLEDBConnection
            SavedBackgroundQuery = .BackgroundQuery
            .BackgroundQuery = False
            .Refresh ' 更新完了まで待つ
            .BackgroundQuery = SavedBackgroundQuery
        End With
        On Error GoTo 0
        Debug.Print String(80, "-")
    Next
    Debug.Print "[Completed] " & Format(Timer - BeforeTime, "00:00:00.000")
End Sub