excelvbaasynchronouspowerquery

VBA - Executing PowerQuery/M Asynchronously


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.


Solution

  • 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