My scenario : I have a few data tables pulled via PowerQuery that I wanted to have automatically refresh the data, save, and close. I had a task scheduler run these every day at 1 AM. The problem was that Excel VBA doesn't wait for the PowerQuery to update before it goes to the next step (save).
There are a LOT of blogs about this, I didn't find any answer - but it led me to something that worked for me! I'm not proud of the code but here it is:
Public Sub DataRefresh()
DisplayAlerts = False
For Each objConnection In ThisWorkbook.Connections
'Get current background-refresh value
bBackground = objConnection.OLEDBConnection.BackgroundQuery
'Temporarily disable background-refresh
objConnection.OLEDBConnection.BackgroundQuery = False
'Refresh this connection
objConnection.Refresh
'Set background-refresh value back to original value
objConnection.OLEDBConnection.BackgroundQuery = bBackground
Next
Workbooks("DA List.xlsm").Model.Refresh
DoEvents
For i = 1 To 100000
Worksheets("DA List").Range("G1") = i
Next i
DoEvents
ActiveWorkbook.Save
Application.Quit
End Sub
I think this works because I gave excel something to do other than the data refresh, and the extra lines between DoEvents and my next step seemed to make VBA finally figure out what I was intending.
Hope this helps!!
Public Sub DataRefresh()
DisplayAlerts = False
For Each objConnection In ThisWorkbook.Connections
'Get current background-refresh value
bBackground = objConnection.OLEDBConnection.BackgroundQuery
'Temporarily disable background-refresh
objConnection.OLEDBConnection.BackgroundQuery = False
'Refresh this connection
objConnection.Refresh
'Set background-refresh value back to original value
objConnection.OLEDBConnection.BackgroundQuery = bBackground
Next
Workbooks("DA List.xlsm").Model.Refresh
DoEvents
For i = 1 To 100000
Worksheets("DA List").Range("G1") = i
Next i
DoEvents
ActiveWorkbook.Save
Application.Quit
End Sub
Related
I have created a VBA code to import data from CSV convert it into a table and refresh the query that is already setup.
I want the user to be informed when the background query is completed by displaying a VBA msgbox.
I tried below code but it doesn't work because if condition would be nothing by the the time query is completed. So no msgbox will be display.
Do I need to setup some delay like 15 sec and display msgbox anyway but then it wouldn't be a good idea.
How to sync background query completion with VBA msgbox?
ThisWorkbook.RefreshAll
Sheets(2).Select
If Sheets(2).Range("AG3").Value <> "" Then MsgBox "Completed"
The Delay is tricky. Sometimes it could be 2 seconds or 10 to update the whole data, and also when the data gets bigger, the system will need more time to update the Data Model. This means that the "MsgBox" could appear when the data still updating.
I understand the perks of the Background Update, but it is important to know that it stops when you save the workbook. Instead, I would block any activity in the workbook until the Data Model is complete updated. For this, I use the following code that I found here long time ago:
Sub Aktualisieren()
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With ThisWorkbook
For Each objConnection In .Connections
'Get current background-refresh value
bBackground = objConnection.OLEDBConnection.BackgroundQuery
'Temporarily disable background-refresh
objConnection.OLEDBConnection.BackgroundQuery = False
'Refresh this connection
objConnection.Refresh
'Set background-refresh value back to original value
objConnection.OLEDBConnection.BackgroundQuery = bBackground
Next
'Save the updated Data
.Save
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data Model Updated"
End Sub
Now, as you ask, if you want to update one specific Query, first you need to know the specific name of it (it is not always the same as you have written). For this run the following code:
Sub Get_Conection_Names()
With ThisWorkbook
'Check if there is any conection
If .Connections.Count = 0 Then Exit Sub
'Print the numer of conection (item number) and its name
For X = 1 To .Connections.Count
Debug.Print X & ": " & .Connections.Item(X).Name
Next X
End With
End Sub
With the information of the Query, you can add to a bottom the following code:
Sub UpdateConectionbyName()
Dim ConectionName As String
ConectionName = "Query - Name of Query"
With ThisWorkbook
'Check if there is any conection
If .Connections.Count = 0 Then Exit Sub
'Check the connections names if one macht with the one we want.
For X = 1 To .Connections.Count
If .Connections.Item(X).Name = ConectionName Then .Connections.Item(X).Refresh
Next X
End With
End Sub
And now, if you want to Refresh a specific Query unabeliing the Background Update, this code will help. Item 1 is the number of the query. You can get it with the code above.
With ThisWorkbook.Connections
bBackground = .Item(1).OLEDBConnection.BackgroundQuery
.Item(1).OLEDBConnection.BackgroundQuery = False
.Item(1).Refresh
.Item(1).OLEDBConnection.BackgroundQuery = bBackground
End With
The purpose of the macro is to avoid creating a new worksheet each time a user double clicks / drills down on a pivot table value. Instead the script copies the data to a dedicated "DrillDown" sheet.
After several clicks, I get an Excel error stating I am out of memory.
The raw dataset is not very big.
I am wondering if there is an issue with the script, or perhaps I need to add something further?
Maybe there is some temp data I need to clear first?
My code:
Module1
Public CS$
This Workbook
Private Sub Workbook_NewSheet(ByVal Sh As Object)
If CS <> "" Then
With Application
ScreenUpdating = False
Dim NR&
With Sheets("DrillDown")
'Set this to always start at the top of the page
NR = 1
'..and to clear the Drilldown tab..
.Cells.ClearContents
'instead of this..
'If WorksheetFunction.CountA(.Rows(1)) = 0 Then
' NR = 1
'Else
' NR = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 2
'End If
Range("A4").CurrentRegion.Copy .Cells(NR, 1)
End With
.DisplayAlerts = False
ActiveSheet.Delete
.DisplayAlerts = True
'Below is commented out to stop user being returned to Pivot
' Sheets(CS).Select
.ScreenUpdating = True
End With
End If
End Sub
It could be the event triggers while the data is still being written to the sheet. You could retain the newly created sheet and delete the previous to avoid copying.
Private Sub Workbook_NewSheet(ByVal Sh As Object)
If CS = "" Then Exit Sub
With Application
.DisplayAlerts = False
On Error Resume Next
Sheets("DrillDown").Delete
Sh.Name = "DrillDown" ' renamenew sheet
On Error GoTo 0
.DisplayAlerts = True
End With
End Sub
I'm going through a peculiar failure in my excel vba macro wherein the excel sheet crashes on the 2nd run of the macro (Yes, 1st run in perfect).
This macro is to delete all data labels except the recent one for a particular series in all graphs in a sheet. Common graph is used with slicer and Data table to select which line item is needed in graph. on every change in slicer (new line items is selected in data table filter), i want the macro to run and do the label work.
Below is source code for the Graph data label work,
Sub Update_labels_Only_To_Last_Data()
Dim myChartObject As ChartObject
Dim mySrs As Series
Dim myPts As Points
Dim iPts As Long
Dim bLabeled As Boolean
Application.EnableEvents = False
Name = ThisWorkbook.Name
Set Wb = Workbooks(Name)
Set WsGraph = Wb.Worksheets("Graph")
WsGraph.Activate
With ActiveSheet
For Each myChartObject In .ChartObjects
For Each mySrs In myChartObject.Chart.SeriesCollection
If mySrs.Name = "TAR" Then
bLabeled = False
With mySrs
For iPts = .Points.Count To 1 Step -1
If bLabeled Then
' handle error if point isn't plotted
On Error Resume Next
' remove existing label if it's not the last point
mySrs.Points(iPts).HasDataLabel = False
On Error GoTo 0
Else
' handle error if point isn't plotted
On Error Resume Next
' add label
mySrs.Points(iPts).ApplyDataLabels _
ShowSeriesName:=False, _
ShowCategoryName:=False, ShowValue:=True, _
AutoText:=True, LegendKey:=False
bLabeled = (Err.Number = 0)
On Error GoTo 0
End If
Next
End With
Set myPts = mySrs.Points
myPts(myPts.Count).ApplyDataLabels Type:=xlShowValue 'Add only to last data
End If
Next
Next
End With
'End If
Application.EnableEvents = True
End Sub
I've tried running macro using a separate button it works perfectly. Then linked this with event macro (Calculation) using below code in sheet (Donotdelete)
Option Explicit
Private Sub Worksheet_Calculate()
Dim Act_Sheet As Worksheet
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculate
If Not Application.CalculationState = xlDone Then 'wait till previous calculation gets over
DoEvents
End If
Set Act_Sheet = ActiveSheet
Application.Wait (Now + TimeValue("0:00:01"))
Call Update_labels_Only_To_Last_Data
Act_Sheet.Activate
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
so once a slicer filter is changed, calculate event is triggered using "Count" function in "Donotdelete" sheet and macro gets run. when first time slicer us changed, macro works perfectly. but when 2nd time the slicer is changed to call different graph, macro gets initiated and all of a sudden, completely sheet gets crashed/closed. Tried in break mode and the code works perfectly. tried giving doevents / wait options and still the result is same. To confirm the crash source, tried skipping the "macro" using comment block in eventmacro sheet & the code works perfectly. on any selection change in slicer, macro goes thro the event macro and works perfectly. with this, source is confirmed to be the macro "Update_labels_Only_To_Last_Data()".
i use the same macro in main module and there it works perfectly any number of consecutive times. could not find why it crashes only when used through even trigger and only on the 2nd time !!!. did all my google help thing for couple of weeks now but no result. see if you guys can show me a wayout.
I have a timer that closes my workbook after 5 minutes. The issue is when i have another workbook open the workbook with the timer will reopen when i try to close it.
Earlier i had the countdown to "tick" every second but that messed up the view of comments making them blink for every countdown tick. When i had that I didn't see any issues with reopening of the workbook.
I have this in both my module and thisworkbook
Public gCount as Date
These two codes are in my module. The timer is displayed in a cell
(Worksheets("kode").Range("H3")) and counts down every 10 seconds
Sub Timer()
gCount = Now + TimeValue("00:00:10")
Application.OnTime gCount, "ResetTime"
End Sub
Sub ResetTime()
Dim xRng As Range
If ThisWorkbook.Worksheets("kode").Range("H3") = "" Then GoTo Endsub
Set xRng = Application.ThisWorkbook.Worksheets("kode").Range("H3")
xRng.Value = xRng.Value - TimeSerial(0, 0, 10)
If xRng.Value <= 1.15740740740741E-05 Then
Call SavedAndClose
Exit Sub
End If
Call Timer
Endsub:
End Sub
This code is in ThisWorkbook
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
gCount = Now + TimeValue("00:00:10")
Application.OnTime gCount, "ResetTime", Schedule:=False
ThisWorkbook.Worksheets("Interface").Select
'Hides all sheets but the interface sheet
Sheet2.Visible = False
Sheet3.Visible = False
Sheet6.Visible = False
Sheet7.Visible = False
Sheet8.Visible = False
End Sub
There too is a place where the cell Worksheets("kode").Range("H3") is set to 00:05:01 and a Workbook_SheetSelectionChange where it resets it to 00:05:01
The sheet closes when Worksheets("kode").Range("H3") is at 00:00:01
If i remove the "On Error Resume Next" the code makes a 1004 run-time error when i try to close the workbook.
Hope that someone can help me close my workbook
Best regards
If i remove the "On Error Resume Next" the code makes a 1004 run-time error when i try to close the workbook.
And that is why you should not put On Error Resume Next everywhere to silence errors instead of fixing them.
Application.OnTime can schedule the same procedure multiple times for different times of day. For this reason, it can only unschedule a previously scheduled entry when you provide the exact time for which it was scheduled - if you provide a time for which there is no scheduled entry, you will get a runtime error 1004.
Now + TimeValue("00:00:10") returns a different value each time you call it.
If you want to be able to cancel a previously set entry, store the time in a module-level variable and use that variable for both scheduling and unscheduling. Your module-level gCount variable would do, but:
You have two of them ("I have this in both my module and thisworkbook")
You overwrite the previously stored value with a useless new one right before calling Schedule:=False.
Make sure you only have one gCount, and only assign to it before scheduling a call, not before unscheduling it.
I found an answer to my own comment to GSergs answer:
I made a Msgbox with vbYesNoCancel options and canceled the OnTime event in the Yes and No answer and work around the generic "Save changes" prompt in excel. If Cancel is pressed the macro will cancel.
The "If xRng.Value <= 1.15740740740741E-05 Then" in the beginning insures that if the timer has run out it skips the MsgBox and just saves.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set xRng = Application.ThisWorkbook.Worksheets("kode").Range("H3")
If xRng.Value <= 1.15740740740741E-05 Then
Application.ScreenUpdating = False
ThisWorkbook.Worksheets("Interface").Select
'Hides all sheets but the interface sheet
Sheet2.Visible = False
Sheet3.Visible = False
Sheet6.Visible = False
Sheet7.Visible = False
Sheet8.Visible = False
Application.OnTime gCount, "ResetTime", Schedule:=False
If ThisWorkbook.Saved = False Then
ThisWorkbook.Save
End If
Application.ScreenUpdating = True
GoTo Endsub
Else
End If
Dim intValue As Integer
intValue = MsgBox("Do you want to save changes?", 3, "Save changes?")
If intValue = 6 Then
Application.ScreenUpdating = False
ThisWorkbook.Worksheets("Interface").Select
'Hides all sheets but the interface sheet
Sheet2.Visible = False
Sheet3.Visible = False
Sheet6.Visible = False
Sheet7.Visible = False
Sheet8.Visible = False
Application.OnTime gCount, "ResetTime", Schedule:=False
If ThisWorkbook.Saved = False Then
ThisWorkbook.Save
End If
Application.ScreenUpdating = True
ElseIf intValue = 7 Then
Application.ScreenUpdating = False
ThisWorkbook.Worksheets("Interface").Select
'Hides all sheets but the interface sheet
Sheet2.Visible = False
Sheet3.Visible = False
Sheet6.Visible = False
Sheet7.Visible = False
Sheet8.Visible = False
Application.OnTime gCount, "ResetTime", Schedule:=False
ThisWorkbook.Saved = True
Application.ScreenUpdating = True
Else
Cancel = True
End If
End Sub
Hope it can help someone with the same issue.
Best regars
Søren
I am having an issue regarding setting a range of cells to be editable by a user after my code runs when the file opens. The file gets a runtime error "Unable to set the locked property of the range class".
I have done some digging online and it appears other people have the same issue when their cells are merged. My cells aren't merged.
What I am trying to do:
Lock all cells on all sheets apart from specific ones
Still allow user to group and ungroup data
The code runs fine without selecting specific cells
Sub Workbook_Open()
Application.StatusBar = "Loading Please Wait..." 'change status bar text
Application.ScreenUpdating = False 'freeze screen
Application.Cursor = xlWait 'change cursor
UserForm1.Show vbModeless 'show loading form
UserForm1.Repaint 'update form
For Each ws In Sheets 'loop for every sheet
With ws
.Unprotect Password:="11Oceans" 'unprotect sheet
.Range("D6:J6").Locked = False 'format certain cells to unprotect -ERROR HERE
.Protect Password:="11Oceans", UserInterfaceOnly:=True 'protect sheet but leave data grouping
.EnableOutlining = True
End With
Next ws 'next worksheet
Application.ScreenUpdating = True 'return control to user
Application.StatusBar = "" 'return status bar to default
Application.Cursor = xlDefault 'return cursor to default
Unload UserForm1 'close loading form
End Sub