RefreshWorkbook.vb

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
#End If

Dim bManualRefresh As Boolean

Sub ManualStart()
    On Error Resume Next
    bManualRefresh = True
    Debug.Print RefreshWorkbook
    bManualRefresh = False
End Sub

Private Sub WaitSeconds(intSeconds As Integer)
    Dim datTime As Date
    Dim sStatusBarInitial As String
    Dim k As Integer
    Dim bScreenUpdatingInitial As Boolean
    Dim CursorInitial As Double
    
    With Application
        bScreenUpdatingInitial = .ScreenUpdating
        CursorInitial = .Cursor
        sStatusBarInitial = IIf(.StatusBar <> False, .StatusBar, vbNullString)
        
        .ScreenUpdating = False
        .Cursor = xlWait
    End With
    
    datTime = DateAdd("s", intSeconds, Now)
    Do
        ' 255 chars is limit of status bar
        If Len(Application.StatusBar) + Len(CStr(CStr(intSeconds - k)) & "...") > 255 Then
            Application.StatusBar = Left(Left(sStatusBarInitial, 255 - Len(CStr(intSeconds - k) & "...") - 1) _
                & " " & CStr(intSeconds - k) & "...", 255)
        Else
            Application.StatusBar = sStatusBarInitial & " " & CStr(intSeconds - k) & "..."
        End If
        ' Yield to other programs (better than using DoEvents which eats up all the CPU cycles)
        Sleep 1000
        DoEvents
        k = k + 1
    Loop Until Now >= datTime

    With Application
        .StatusBar = sStatusBarInitial
        .ScreenUpdating = bScreenUpdatingInitial
        .Cursor = CursorInitial
    End With
End Sub

Function RefreshWorkbook(Optional Wb As Workbook) As Boolean
    Dim cnct As Variant
    Dim slc As SlicerCache
    Dim BeforeAction
    Dim target_wb As Workbook
    Dim bCubeFormulasFound As Boolean
    Dim bScreenUpdatingInitial As Boolean
    Dim bEnableEventsInitial As Boolean
    Dim CalcModeInitial As Double
    Dim CursorStateInitial As Double
    
    On Error GoTo ErrHandler
    Debug.Print Now, "Updating connections..."
    
    With Application
        bScreenUpdatingInitial = .ScreenUpdating
        bEnableEventsInitial = .EnableEvents
        CalcModeInitial = .Calculation
        CursorStateInitial = .Cursor
        
        ' switch everything off
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .Cursor = xlWait
    End With
    
    If Wb Is Nothing Then
        Set target_wb = ThisWorkbook
    Else
        Set target_wb = Wb
    End If
    
    On Error Resume Next
    If IsError(target_wb.Model.ModelTables.Count) Then
        ' cannot access model
        ' do nothing
    Else
        If target_wb.Model.ModelTables.Count > 0 Then
            Application.StatusBar = "Initializing Data Model..."
            target_wb.Model.Initialize
            WaitSeconds 5
        End If
    End If
    
    Err.Clear
    On Error GoTo ErrHandler
    
    ' deny background refresh
    ' ToThink - probably worth to restore initial settings
    ' however, if workbook is done for Power Refresh solution, it should not contain "background" connections
    ' create 2D array, restore settings after update
    Application.StatusBar = "Switching off background refresh..."
    On Error Resume Next
    For Each cnct In target_wb.Connections
        Select Case cnct.Type
            Case xlConnectionTypeODBC
                cnct.ODBCConnection.BackgroundQuery = False
            Case xlConnectionTypeOLEDB
                cnct.OLEDBConnection.BackgroundQuery = False
        End Select
    Next cnct
    Err.Clear
    On Error GoTo ErrHandler

    Application.StatusBar = "Refreshing Data Model and Connections..."
    target_wb.RefreshAll
    WaitSeconds 1
    Application.CalculateUntilAsyncQueriesDone
    WaitSeconds 1
    
    ' Check readyness
    For Each cnct In target_wb.Connections
        Select Case cnct.Type
            Case xlConnectionTypeODBC
                Do While cnct.ODBCConnection.Refreshing
                    WaitSeconds 1
                Loop
            Case xlConnectionTypeOLEDB
                Do While cnct.OLEDBConnection.Refreshing
                    WaitSeconds 1
                Loop
        End Select
    Next cnct
    
    Application.StatusBar = "Calculating after connections refresh..."
    Application.Calculate
    Application.CalculateUntilAsyncQueriesDone
    WaitSeconds 1
    
    Application.StatusBar = "Checking existence of cube formulas..."
    bCubeFormulasFound = IsWBHasCubeFormulas(target_wb)
    
    ' update cache after Model refresh
    ' ignore all possible errors with slicers
    On Error Resume Next
    Application.StatusBar = "Updating slicers..."
    For Each slc In target_wb.SlicerCaches
        slc.ClearManualFilter
        slc.ClearAllFilters
        'slc.ClearDateFilter
    Next slc
    Err.Clear
    On Error GoTo ErrHandler
    ' if needed, slicer default value can be set in BeforeSave event of target workbook, or in custom macro
    
    If bCubeFormulasFound Then
        ' wait for refresh of cube formulas
        If target_wb.SlicerCaches.Count > 0 Then
            Application.StatusBar = "Calculating after slicers refresh..."
            Application.Calculate
            Application.CalculateUntilAsyncQueriesDone
        End If
        
        Application.StatusBar = "Waiting for cube formulas..."
        WaitSeconds 20
    End If
    
    If Not Application.CalculationState = xlDone Then
        ' infinite loop can be trully infinite
        ' so just delay
        Application.StatusBar = "Waiting for application to calculate..."
        WaitSeconds 5
    End If
        
    RefreshWorkbook = True

Exit_Function:
    On Error Resume Next
    
    ' restore initial state
    With Application
        .ScreenUpdating = bScreenUpdatingInitial
        .EnableEvents = bEnableEventsInitial
        .Calculation = CalcModeInitial
        .Cursor = CursorStateInitial
        .StatusBar = vbNullString
    End With
    
    Exit Function
    
ErrHandler:
    Debug.Print Now, "Update Connections", Err.Number, Err.Description, Application.StatusBar
    
    If bManualRefresh Then
        Application.Cursor = xlDefault
        Stop
    End If
    
    Err.Clear
    GoTo Exit_Function
    Resume ' for debug purpose
End Function

Private Function IsWBHasCubeFormulas(Optional Wb As Workbook) As Boolean
    Dim sh As Worksheet
    Dim cell As Range
    Dim bFound As Boolean
    Dim bScreenUpdatingInitial As Boolean
    Dim bEnableEventsInitial As Boolean
    Dim CalcModeInitial As Integer
    Dim rngFormulas As Range
    
    On Error GoTo ErrHandler
    
    If Wb Is Nothing Then
        Set Wb = ThisWorkbook ' ActiveWorkbook ' alternatively
    End If
    
    With Application
        bScreenUpdatingInitial = .ScreenUpdating
        bEnableEventsInitial = .EnableEvents
        CalcModeInitial = .Calculation
        
        ' switch everything off
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    For Each sh In Wb.Sheets
        'Debug.Print sh.Name
        
        Err.Clear
        On Error Resume Next
        Set rngFormulas = sh.Cells.SpecialCells(xlCellTypeFormulas)
        bFound = (Err.Number = 0) ' no error, means SpecialCells returned non-empty range
        Err.Clear
        On Error GoTo ErrHandler
        
        ' if result of SpecialCells was non-empty - check formulas
        If bFound Then
            For Each cell In rngFormulas
                'Debug.Print cell.Formula
                If Left(cell.Formula, 5) = "=CUBE" Then
                    IsWBHasCubeFormulas = True
                    GoTo Exit_Function
                End If
            Next cell
        End If
    Next sh
    
Exit_Function:
    On Error Resume Next
    
    ' restore initial state
    With Application
        .ScreenUpdating = bScreenUpdatingInitial
        .EnableEvents = bEnableEventsInitial
        .Calculation = CalcModeInitial
    End With
    
    Exit Function
    
ErrHandler:
    If Err.Number <> 0 Then
        Debug.Print Now, "IsWBHasCubeFormulas", Err.Number & ": " & Err.Description
        Err.Clear
    End If
    
    GoTo Exit_Function
    Resume ' for debug purpose
End Function

thank you. the best solution over internet

thank you. the best solution over internet

Thanks @alifath11234! Glad you found it useful!