VBA - Executing PowerQuery/M Asynchronously

Question

So I've made a sub which creates a new workbook, and executes Mashup (PowerQuery code) within it:

Public Sub ExecuteM(ByVal mCode As String)
  Dim wb As Workbook: Set wb = Workbooks.add()
  Dim query As WorkbookQuery: Set query = wb.Queries.add("PQ", mCode)
  Dim ws As Worksheet: Set ws = wb.Sheets(1)
  Dim lo As ListObject: Set lo = ws.ListObjects.add(xlSrcQuery, "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=PQ;Extended Properties=""""", Destination:=ws.Range("A1"))
  Dim qt As QueryTable: Set qt = lo.QueryTable
  qt.CommandType = xlCmdSql
  qt.CommandText = Array("SELECT * FROM [PQ]")
  
  'Refresh async...
  Call qt.Refresh(True)
  
  'The data will never populate...
  While qt.Refreshing
    DoEvents
  Wend
End Sub

The problem with the above code is it will never actually resolve... For instance, let's run a simple example:

Sub testM()
  Call ExecuteM("#table({""a"",""b""},{{1,2},{3,4}})")
End Sub

If you run the macro, you will see a workbook is created, the list object is created and claims it's loading the data. However it will not actually load the data until VBA runtime is aborted or VBE debug mode is entered.

So the question is, is there a way to force Excel to load data to the sheet? Or better still, is there a means that we can get at these data without having to load it into excel as a list object?

Demonstration of issue: https://youtu.be/JYRUbWQ8mxk

---

FYI - This is a simplified example of my code. In reality I've got many simultaneous running fibers using stdFiber. So async would be really useful here as I can run many queries in parallel. But aborting runtime just isn't really feasible without a rework of stdFiber and utilising something like StateLossCallback.

Answer 1

One way to do this would be to use .OnTime to schedule a check (CheckQueryRefreshStatus) for when the query is refreshed then let VBA stop its execution for enough time to let the query run. The status checking method also needs to call itself with .OnTime if the query isn't refreshed yet.

Example:

Private qt As QueryTable

Sub testM()
  Call ExecuteM("#table({""a"",""b""},{{1,2},{3,4}})")
End Sub

Public Sub ExecuteM(ByVal mCode As String)
    Dim wb As Workbook: Set wb = Workbooks.Add()
    Dim query As WorkbookQuery: Set query = wb.Queries.Add("PQ", mCode)
    Dim ws As Worksheet: Set ws = wb.Sheets(1)
    Dim lo As ListObject
    Set lo = ws.ListObjects.Add(xlSrcQuery, _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=PQ;Extended Properties=""""", _
        Destination:=ws.Range("A1"))
    
    Set qt = lo.QueryTable
    qt.CommandType = xlCmdSql
    qt.CommandText = Array("SELECT * FROM [PQ]")
    
    ' Refresh async
    Call qt.Refresh(True)

    ' Use OnTime to check status later
    Application.OnTime Now + TimeValue("00:00:01"), "CheckQueryRefreshStatus"
End Sub

Public Sub CheckQueryRefreshStatus()
    
    ' If still refreshing, check again in 1 second
    If qt.Refreshing Then
        Application.OnTime Now + TimeValue("00:00:01"), "CheckQueryRefreshStatus"
    Else

        MsgBox "Query refresh complete!", vbInformation
        
    End If
    
End Sub

Inside the if-statement in CheckQueryRefreshStatus, you can call another sub instead of the MsgBox. The only downside of this approach is that you'd have to define relevant variables at the module-level so that all subs have access to them and you can resume execution with the right context once the query is refreshed.

---

EDIT1: Since you mentioned that you'd want to run multiple queries in parallel, you could then use a dictionnary to store the name of the query and run them in parallel like so:

Private PendingQueries As Object

Sub testM()

    ' Initialize the dictionary
    Set PendingQueries = CreateObject("Scripting.Dictionary")
    
    ' Execute multiple queries in parallel
    Call ExecuteM("Query1", "#table({""a"",""b""},{{1,2},{3,4}})")
    Call ExecuteM("Query2", "#table({""c"",""d""},{{1,2},{3,4}})")
    
End Sub

Public Sub ExecuteM(ByVal QueryName As String, ByVal mCode As String)
    Dim wb As Workbook: Set wb = Workbooks.Add()
    Dim query As WorkbookQuery: Set query = wb.Queries.Add("PQ", mCode)
    Dim ws As Worksheet: Set ws = wb.Sheets(1)
    Dim lo As ListObject
    Set lo = ws.ListObjects.Add(xlSrcQuery, _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=PQ;Extended Properties=""""", _
        Destination:=ws.Range("A1"))

    Dim qt As QueryTable
    Set qt = lo.QueryTable
    qt.CommandType = xlCmdSql
    qt.CommandText = Array("SELECT * FROM [PQ]")
    
    ' Store query in the dictionary
    PendingQueries.Add QueryName, qt

    ' Refresh asynchronously
    Call qt.Refresh(True)

    ' Start monitoring queries if not already running
    If PendingQueries.Count = 1 Then
        Application.OnTime Now + TimeValue("00:00:01"), "CheckQueriesRefreshStatus"
    End If
End Sub

Public Sub CheckQueriesRefreshStatus()
    Dim i As Integer
    Dim qt As QueryTable
    Dim keysToRemove As Collection
    Set keysToRemove = New Collection

    ' Check all queries in the dictionary
    Dim Key As Variant
    For Each Key In PendingQueries.Keys
        Set qt = PendingQueries(Key)
        If Not qt.Refreshing Then
            ' Mark this query for removal
            keysToRemove.Add Key
        End If
    Next Key

    ' Remove completed queries
    For i = 1 To keysToRemove.Count
        MsgBox keysToRemove(i) & " refresh complete!", vbInformation
        PendingQueries.Remove keysToRemove(i)
    Next i

    ' If there are still queries running, check again in 1 second
    If PendingQueries.Count > 0 Then
        Application.OnTime Now + TimeValue("00:00:01"), "CheckQueriesRefreshStatus"
    Else
        MsgBox "All queries have finished refreshing!", vbInformation
    End If
End Sub

Here, CheckQueriesRefreshStatus is looking at all the queries stored in PendingQueries at the same time and is waiting for Excel to complete them all in parallel.

---

EDIT2: And if you really don't want to stop VBA's execution, the only way I can think of is to create another Excel Application to perform the query in parallel like below (I also added some Sleep to the loop to make it more efficient, but that remains optional).

'Declare the Sleep() method from the Windows API
#If VBA7 Then ' Excel 2010 or later
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else ' Excel 2007 or earlier
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If


Sub testM()
  Call ExecuteM("#table({""a"",""b""},{{1,2},{3,4}})")
End Sub

Public Sub ExecuteM(ByVal mCode As String)

    Dim xlApp As Excel.Application
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    xlApp.WindowState = xlMaximized

    Dim wb As Workbook: Set wb = xlApp.Workbooks.Add()
    Dim query As WorkbookQuery: Set query = wb.Queries.Add("PQ", mCode)
    Dim ws As Worksheet: Set ws = wb.Sheets(1)
    Dim lo As ListObject: Set lo = ws.ListObjects.Add(xlSrcQuery, "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=PQ;Extended Properties=""""", Destination:=ws.Range("A1"))
    Dim qt As QueryTable: Set qt = lo.QueryTable
    qt.CommandType = xlCmdSql
    qt.CommandText = Array("SELECT * FROM [PQ]")
    
    'Refresh async...
    Call qt.Refresh(True)
    
    'The data will populate
    While qt.Refreshing
        DoEvents
        Sleep 200
    Wend
    
    Set xlApp = Nothing
    
End Sub