VBA to optimise Refresh and list all Connections with refresh time

[Melimob]

Hi there,

I want to have a sheet which lists all the PQ connections, PP Data Models and PivotTables in the workbook and shows
1) when they were last refreshed
2) how long it took to refresh
3) any errors stopping refresh
4) the order they are refreshed when 'RefreshAll'
5) background enable enabled/disabled (*I have turned this off for all already via VBA code)
6) user who refreshed
7) what PQ are linked to which or preferably: Show the source data of each query

8) I also wanted to show either a progress bar or a msgbox when refresh has been completed.

9) Lastly any code to to remove and re-add data source settings to organisational as other users can't refresh the queries?

I found some really great code which gives me some of this but doesn't provide date and time taken which are the main points I wanted.

Reason for this is its taking so long to refresh that I want to see which ones are the issues and whether I really need them anymore.
Trying to clean up the file to make it faster.
Ensure other colleagues can refresh without issues.

Here's the code I have and the output it currently shows:

Option Explicit
Private Function GetWbSheet(wb As Workbook, sheetName As String) As Worksheet
    Set GetWbSheet = Nothing
    On Error Resume Next
    Set GetWbSheet = wb.Worksheets(sheetName)
    On Error Resume Next
End Function


Public Sub List_Workbook_Connections()

    Dim wb As Workbook
    Dim qcSheet As Worksheet, r As Long, tableStartRow As Long
    Dim wbConn As WorkbookConnection
    Dim wbcTable As ListObject
      
    'Either operate on this macro workbook
    'Set wb = ThisWorkbook
    'Or operate on the active workbook
    Set wb = ActiveWorkbook
  
    Set qcSheet = GetWbSheet(wb, "Conns")
    If qcSheet Is Nothing Then
        With wb
            Set qcSheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
            qcSheet.Name = "Conns"
        End With
    End If
    qcSheet.Cells.Clear

    r = 1
    tableStartRow = r
    qcSheet.Cells(r, "A").Resize(, 9).Value = Array("Name", "Description", "RefreshDate", "RefreshWithAll", "EnableRefresh", "InModel", "Type", "ODBC/OLEDB", "CommandText")
    r = r + 1
  
    For Each wbConn In wb.Connections
        qcSheet.Cells(r, "A").Value = wbConn.Name
        Select Case wbConn.Type
            Case Is = xlConnectionTypeODBC
                qcSheet.Cells(r, "B").Value = wbConn.Description
                On Error Resume Next
                qcSheet.Cells(r, "C").Value = wbConn.ODBCConnection.RefreshDate
                On Error GoTo 0
                qcSheet.Cells(r, "D").Value = wbConn.RefreshWithRefreshAll
                qcSheet.Cells(r, "E").Value = wbConn.ODBCConnection.EnableRefresh
                qcSheet.Cells(r, "F").Value = wbConn.InModel
                qcSheet.Cells(r, "G").Value = wbConn.Type
                qcSheet.Cells(r, "H").Value = "ODBC"
                qcSheet.Cells(r, "I").Value = wbConn.ODBCConnection.CommandText
                
            Case Is = xlConnectionTypeOLEDB
                
                qcSheet.Cells(r, "B").Value = wbConn.Description
                On Error Resume Next
                qcSheet.Cells(r, "C").Value = wbConn.OLEDBConnection.RefreshDate
                On Error GoTo 0
                qcSheet.Cells(r, "D").Value = wbConn.RefreshWithRefreshAll
                qcSheet.Cells(r, "E").Value = wbConn.OLEDBConnection.EnableRefresh
                qcSheet.Cells(r, "F").Value = wbConn.InModel
                qcSheet.Cells(r, "G").Value = wbConn.Type
                qcSheet.Cells(r, "H").Value = "OLEDB"
                qcSheet.Cells(r, "I").Value = wbConn.OLEDBConnection.CommandText
        
        
            'Case Is = xlConnectionTypeMODEL
        
                'qcSheet.Cells(r, "B").Value = wbConn.Description
                'On Error Resume Next
                'qcSheet.Cells(r, "C").Value = wbConn.ModelConnection.RefreshDate
               ' On Error GoTo 0
               ' qcSheet.Cells(r, "D").Value = wbConn.RefreshWithRefreshAll
               ' qcSheet.Cells(r, "E").Value = wbConn.ModelConnection.EnableRefresh
               ' qcSheet.Cells(r, "F").Value = wbConn.InModel
               ' qcSheet.Cells(r, "G").Value = wbConn.Type
               ' qcSheet.Cells(r, "H").Value = "MODEL"
               ' qcSheet.Cells(r, "I").Value = wbConn.ModelConnection.CommandText
        
        
        
        
        
        End Select
        r = r + 1
    Next

    With qcSheet
        Set wbcTable = .ListObjects.Add(xlSrcRange, .Cells(tableStartRow, "A").Resize(r - tableStartRow, 10), , xlYes)
        wbcTable.Name = "WorkbookConnections_Table"
    End With

End Sub

Output Sample: (Although 'Enable Refresh' column is not accurate as I've disabled this for all).

Here's the code which I thought I could try and adapt to get time and notification but I get an error:

Sub MyProcedure()

    '
    ' Some procedures
    '
    ActiveWorkbook.RefreshAll
    Call NotifyWhenRefreshComplete
End Sub



Private Sub NotifyWhenRefreshComplete()
    Const PulseTimer As Currency = TimeValue("00:00:01")
    Dim b1 As Boolean, b2 As Boolean

    b1 = Sheet29.Range("ListObject1").ListObject.QueryTable.Refreshing
    b2 = Sheet29.Range("ListObject2").ListObject.QueryTable.Refreshing

    If b1 Or b2 Then
        Call Application.OnTime(Now + PulseTimer, "NotifyWhenRefreshComplete")
    Else
        Call MsgBox("Refresh Complete.", vbOKOnly)
    End If
End Sub

I know this is a huge Christmas want list but I'll be glad of anything from the list I can get or advice on how to achieve a quick refresh for any user.
FYI (I have table buffered my source queries too).

Many thanks
Melissa

 

[John_w]

I want to have a sheet which lists all the PQ connections, PP Data Models and PivotTables in the workbook and shows
1) when they were last refreshed
2) how long it took to refresh
3) any errors stopping refresh
4) the order they are refreshed when 'RefreshAll'
5) background enable enabled/disabled (*I have turned this off for all already via VBA code)
6) user who refreshed
7) what PQ are linked to which or preferably: Show the source data of each query

Here's something which should answer points 1, 2 and 5, and maybe 6 and 7 with additional code.

Your List_Workbook_Connections routine loops through all the connections in the workbook, and outputs details about them. Although the VBA Object Browser shows that RefreshDate is a property of the ODBCConnection object (for example), its value is not available, hence the error handling here:

                On Error Resume Next
                qcSheet.Cells(r, "C").Value = wbConn.ODBCConnection.RefreshDate
                On Error GoTo 0

and therefore column C is always empty.

My code below (a class module named clsQuery) uses a QueryTable event handler to capture the BeforeRefresh and AfterRefresh events which occur when a QueryTable is refreshed and stores the date-time of both events, the refresh count, the success/failure flag and the QueryTable itself, from which the BackgroundQuery flag can be read.

One issue, handled by my code (in Create_Workbook_Connections_Dictionary) , is that a QueryTable is a property of a ListObject (table), however a WorkbookConnection object does not contain the QueryTable nor the ListObject that the data imported by the connection is related to. To find the ListObject (table) related to a connection, the code loops through the connection's locations (ranges) and finds the intersecting table. With this table we can access the related QueryTable and therefore capture its BeforeRefresh and AfterRefresh events. The code stores every connection and its related ListObject (table) in a Dictionary, using the connection's name as the dictionary key. My modified List_Workbook_Connections routine then uses the connection name to access the correct dictionary item and retrieve the Refresh Count, Last Refresh Date, Elapsed time (the AfterRefresh event time minus the BeforeRefresh event time), Refresh Success flag and BackgroundQuery flag and put them in the "Conns" sheet.

Here is the code:

1. Class module named clsQuery. Note - you must change the class module's name from the default name assigned to it (e.g. Class1) to clsQuery, otherwise none of the code will work.

'Class module - clsQuery

'Each instance of this class contains details about a specific workbook connection and handles
'the BeforeRefresh and AfterRefresh events when the associated QueryTable is changed.

Option Explicit

Private WithEvents pQueryTable As QueryTable

Private pWbConn As WorkbookConnection
Private pTable As ListObject
Private pBeforeRefreshDate As Date
Private pAfterRefreshDate As Date
Private pRefreshCount As Long
Private pRefreshSuccess As Boolean


Public Sub Init_Connection_QueryTable(wbConn As WorkbookConnection, table As ListObject)
  
    'Initialise an instance of a clsQuery object to handle QueryTable events on the specified table
  
    Set pQueryTable = table.QueryTable
    Set pWbConn = wbConn
    Set pTable = table
  
    pBeforeRefreshDate = 0
    pAfterRefreshDate = 0
    pRefreshCount = 0
    pRefreshSuccess = False
  
End Sub


Private Sub pQueryTable_BeforeRefresh(Cancel As Boolean)
    pBeforeRefreshDate = Now
    pRefreshCount = pRefreshCount + 1
    With pQueryTable
        Debug.Print "BeforeRefresh: " & Time
        Debug.Print "RefreshCount " & pRefreshCount
        Debug.Print pWbConn.Name, pTable.Name, .Destination.Worksheet.Name & "!" & .Destination.Address
    End With
End Sub


Private Sub pQueryTable_AfterRefresh(ByVal Success As Boolean)
    pAfterRefreshDate = Now
    pRefreshSuccess = Success
    With pQueryTable
        Debug.Print "AfterRefresh:  " & Time
        Debug.Print "Success:       " & Success
        Debug.Print pWbConn.Name, pTable.Name, .Destination.Worksheet.Name & "!" & .Destination.Address
    End With
    Debug.Print "Elapsed = " & Format(pBeforeRefreshDate - pAfterRefreshDate, "hh:mm:ss")
End Sub

Public Property Get QueryTable() As QueryTable
    Set QueryTable = pQueryTable
End Property

Public Property Get BeforeRefreshDate() As Date
    BeforeRefreshDate = pBeforeRefreshDate
End Property

Public Property Get AfterRefreshDate() As Date
    AfterRefreshDate = pAfterRefreshDate
End Property

Public Property Get RefreshCount() As Long
    RefreshCount = pRefreshCount
End Property

Public Property Get RefreshSuccess() As Boolean
    RefreshSuccess = pRefreshSuccess
End Property

Public Function ElapsedTime() As String

    If pBeforeRefreshDate > 0 And pAfterRefreshDate > 0 And pAfterRefreshDate >= pBeforeRefreshDate Then
        ElapsedTime = Format(pBeforeRefreshDate - pAfterRefreshDate, "hh:mm:ss")
    Else
        ElapsedTime = "NONE"
    End If
  
End Function

2. Standard module which contains two routines - Create_Workbook_Connections_Dictionary and the modified List_Workbook_Connections.

Option Explicit

'Dictionary which holds multiple clsQuery objects

Public connectionsDict As Object 'Scripting.Dictionary

Public Sub Create_Workbook_Connections_Dictionary()

    Dim wbConn As WorkbookConnection
    Dim wbConnRange As Range
    Dim wbConnTable As ListObject
    Dim thisQuery As clsQuery
  
    'Create dictionary to hold multiple clsQuery objects
  
    Set connectionsDict = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
  
    For Each wbConn In ThisWorkbook.Connections
  
        'Loop through all locations in this connection
      
        For Each wbConnRange In wbConn.Ranges
      
            'Find table which intersects this location

            Set wbConnTable = Get_Wb_Connection_Table(wbConnRange.Worksheet, wbConnRange)
          
            'Create a new instance of a clsQuery with this workbook connection and related table and add it to the dictionary
          
            Set thisQuery = New clsQuery
            thisQuery.Init_Connection_QueryTable wbConn, wbConnTable
            connectionsDict.Add wbConn.Name, thisQuery
          
        Next
      
    Next
  
End Sub


Private Function Get_Wb_Connection_Table(connectionWs As Worksheet, connectionRange As Range)

    'Find the ListObject (table) associated with the specified worksheet and range
  
    Dim table As ListObject
  
    For Each table In connectionWs.ListObjects
        If Not Intersect(table.Range, connectionRange) Is Nothing Then
            Set Get_Wb_Connection_Table = table
            Exit Function
        End If
    Next
  
End Function


Public Sub List_Workbook_Connections()

    Dim qcSheet As Worksheet, r As Long
    Dim wbConn As WorkbookConnection
    Dim wbConnTable As ListObject
    Dim thisRange As Range, rangesList As String
    Dim thisQuery As clsQuery
    
    'Create dictionary of all workbook connections if it doesn't exist
  
    If connectionsDict Is Nothing Then
        Create_Workbook_Connections_Dictionary
    End If
    
    Set qcSheet = GetWbSheet(ThisWorkbook, "Conns")
    If qcSheet Is Nothing Then
        With ThisWorkbook
            Set qcSheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
            qcSheet.Name = "Conns"
        End With
    End If
  
    r = 1
  
    With qcSheet
        .Cells.Clear
        .Cells(r, "A").Resize(, 13).Value = Array("Connection Name", "Description", "Num Locations", "Locations", "Refresh Count", "Last Refresh Date", "Elapsed", "Refresh Success", _
                                                  "BackgroundQuery", "RefreshWithAll", "EnableRefresh", "Type", "CommandText")
      
        Set wbConnTable = .ListObjects.Add(xlSrcRange, .Cells(r, "A").Resize(, .Cells(1, .Columns.Count).End(xlToLeft).Column), , xlYes)
        r = r + 1
    End With

    With wbConnTable
        .Name = "WorkbookConnections_Table"
        'Define cell formats. Format for Last Refresh Date column displays empty cell for zero date
        .ListColumns("Last Refresh Date").Range.NumberFormat = "dd/mm/yyyy hh:mm:ss;;"
        .ListColumns("Elapsed").Range.NumberFormat = "[h]:mm:ss"
    End With
 
    For Each wbConn In ThisWorkbook.Connections
  
        'Create list of ranges for this connection
      
        rangesList = ""
        For Each thisRange In wbConn.Ranges
            rangesList = rangesList & thisRange.Worksheet.Name & " " & thisRange.Address & ", "
        Next
      
        With qcSheet
         
            'Properties common to all connection types
          
            .Cells(r, "A").Value = wbConn.Name
            .Cells(r, "B").Value = wbConn.Description
            .Cells(r, "C").Value = wbConn.Ranges.Count
            .Cells(r, "D").Value = Left(rangesList, Len(rangesList) - 2)
          
            If connectionsDict.Exists(wbConn.Name) Then
                'This workbook connection exists in the dictionary, so retrieve its clsQuery instance
                Set thisQuery = connectionsDict.Item(wbConn.Name)
                .Cells(r, "E").Value = thisQuery.RefreshCount
                .Cells(r, "F").Value = thisQuery.BeforeRefreshDate
                .Cells(r, "G").Value = thisQuery.AfterRefreshDate - thisQuery.BeforeRefreshDate
                .Cells(r, "H").Value = thisQuery.RefreshSuccess
                .Cells(r, "I").Value = thisQuery.QueryTable.BackgroundQuery
            Else
                'This workbook connection doesn't exist in the dictionary
                .Cells(r, "E").Value = 0
                .Cells(r, "F").Value = 0
                .Cells(r, "G").Value = 0
                .Cells(r, "H").Value = ""
                .Cells(r, "I").Value = ""
            End If
          
            .Cells(r, "J").Value = wbConn.RefreshWithRefreshAll
          
            'Properties specific to each connection type
          
            Select Case wbConn.Type
          
                Case Is = xlConnectionTypeODBC
                    .Cells(r, "K").Value = wbConn.ODBCConnection.EnableRefresh
                    .Cells(r, "L").Value = wbConn.Type & " - ODBC"
                    .Cells(r, "M").Value = Replace(wbConn.ODBCConnection.CommandText, vbCrLf, " ")
                  
                Case Is = xlConnectionTypeOLEDB
                    .Cells(r, "K").Value = wbConn.ODBCConnection.EnableRefresh
                    .Cells(r, "L").Value = wbConn.Type & " - OLEDB"
                    .Cells(r, "M").Value = Replace(wbConn.OLEDBConnection.CommandText, vbCrLf, " ")
          
                Case Is = xlConnectionTypeMODEL
                    .Cells(r, "K").Value = wbConn.ModelConnection.EnableRefresh
                    .Cells(r, "L").Value = wbConn.Type & " - MODEL"
                    .Cells(r, "M").Value = Replace(wbConn.ModelConnection.CommandText, vbCrLf, " ")
              
                Case Is = xlConnectionTypeDATAFEED
                    .Cells(r, "K").Value = wbConn.DataFeedConnection.EnableRefresh
                    .Cells(r, "L").Value = wbConn.Type & " - DATAFEED"
                    .Cells(r, "M").Value = Replace(wbConn.DataFeedConnection.CommandText, vbCrLf, " ")
              
                Case Is = xlConnectionTypeNOSOURCE
          
                    .Cells(r, "L").Value = wbConn.Type & " - NOSOURCE"
              
                Case Is = xlConnectionTypeTEXT
          
                    .Cells(r, "L").Value = wbConn.Type & " - TEXT"
              
                Case Is = xlConnectionTypeWEB
          
                    .Cells(r, "L").Value = wbConn.Type & " - WEB"
              
                Case Is = xlConnectionTypeWORKSHEET
          
                    .Cells(r, "L").Value = wbConn.Type & " - WORKSHEET"
                    .Cells(r, "M").Value = Replace(wbConn.WorksheetDataConnection.CommandText, vbCrLf, " ")
              
                Case Is = xlConnectionTypeXMLMAP
          
                    .Cells(r, "L").Value = wbConn.Type & " - XMLMAP"
      
            End Select
      
        End With
      
        r = r + 1
      
    Next

End Sub

Private Function GetWbSheet(wb As Workbook, sheetName As String) As Worksheet
    Set GetWbSheet = Nothing
    On Error Resume Next
    Set GetWbSheet = wb.Worksheets(sheetName)
    On Error Resume Next
End Function

You must call Create_Workbook_Connections_Dictionary, either from your own code, or manually from the Excel Macros UI or from the Workbook_Open event in the ThisWorkbook module:

Private Sub Workbook_Open()
    Create_Workbook_Connections_Dictionary
End Sub

to create the BeforeRefresh and AfterRefresh class event handlers for every connection in the workbook.