I have the following Sub. The script causes some information to be written to a table of fixed length every 15 seconds. The results are then graphed to create a real-time moving graph feeling.
The problem is that when I uncomment the line where it saves the workbook, I notice in the task manager that Excel uses more memory (about 3000KB), and holds it. Eventually, Excel runs out of memory and crashes. I have tried setting my objects and stuff to Nothing, but that doesn't help. It's all due to the save line, but I don't really know why. How can I save, and avoid the memory problem?
Sub Record()
Dim BookValueTable As ListObject: Set BookValueTable = Range("bookvalue_table").ListObject
If Sheets("Orders").LoggingButton.Value And _
BookValueTable.Range(BookValueTable.ListRows.Count + 1, 1) <> Now Then
Dim NewRow As ListRow: Set NewRow = BookValueTable.ListRows.Add(AlwaysInsert:=True)
NewRow.Range(1, 1) = Now
NewRow.Range(1, 2) = Sheets("Orders").Range("total_dollar_pnl")
While BookValueTable.ListRows.Count >= 28800
BookValueTable.ListRows(1).Delete
Wend
ThisWorkbook.RefreshAll
If Hour(Now) = 17 Then
Application.OnTime TimeValue("18:00:00"), "Record"
Else
Application.OnTime Now + TimeValue("00:00:" & 15 - (Second(Now) Mod 15)), "Record"
End If
'Workbooks("Book1.xlsm").Save
End If
Set BookValueTable = Nothing
Set NewRow = Nothing
End Sub
Related
I'm trying to write a vba script that gets called in a batch file to open an excel file, refresh bloomberg data, save the file, and then quit excel.
There was a historical question which asked something similar, but the suggested answer didn't seem to work - I can open the file and refresh the data, but it doesn't save the file or close excel.
I tried also putting in as a macro with the workbook_open file, but then ran into a problem where excel is saving and closing the file before refreshing the data. Any suggestions would be much appreciated.
Immediately below is the modified vba code that refreshes the data, but doesn't save or close the excel workbook.
'Write Excel.xls Sheet's full path here
strPath = "C:\MngXL\testbook.xlsm"
'Create an Excel instance and set visibility of the instance
Set objApp = CreateObject("Excel.Application")
objApp.Visible = True
Set wbToRun = objApp.Workbooks.Open(strPath)
StartAutomation
DoneNow
Sub StartAutomation()
Dim oAddin
Set oAddin = objApp.Workbooks.Open("C:\blp\API\Office Tools\BloombergUI.xla")
If Not oAddin Is Nothing Then
objApp.DisplayAlerts = False
objApp.Calculate
objApp.Run "RefreshAllStaticData"
objApp.Calculate
objApp.Run "RefreshAllStaticData"
'WaitTillUpdateComplete
End If
dim count
dim updated
updated = false
for count = 0 to 12
if updated = false then
if objApp.WorksheetFunction.CountIf(objApp.Range("rng_inWorkbook"),"#N/A Requesting Data...") = 0 Then
updated = true
else
Application.OnTime Now + TimeValue("00:00:15"), WaitTillUpdateComplete
end if
end if
next
End Sub
Private Sub WaitTillUpdateComplete()
Dim t
t = 0
objApp.Calculate
If objApp.WorksheetFunction.CountIf(objApp.Range("rng_inWorkbook"),"#NAME?") > 0 Then
Application.OnTime Now + TimeValue("00:00:15"), "WaitTillUpdateComplete"
ElseIf objApp.WorksheetFunction.CountIf(objApp.Range("rng_inWorkbook"),"#N/A") > 0 Then
Application.OnTime Now + TimeValue("00:00:15"), "WaitTillUpdateComplete"
ElseIf objApp.WorksheetFunction.CountIf(objApp.Range("rng_inWorkbook"),"#N/A Requesting Data...") > 0 Then
If t < 5 Then
t = t+ 1
waitlonger
Else
Exit Sub
End If
Else
Exit Sub
End If
End Sub
Sub waitlonger()
Dim x
x = Now + TimeValue("00:00:40")
Do While x > Now
Loop
objApp.Calculate
End Sub
Sub DoneNow()
wbToRun.Save
wbToRun.Close
objApp.DisplayAlerts = False
objApp.Quit
MsgBox strPath & " " & strMacro & " macro and .vbs successfully completed!!!!", vbInformation
End Sub
You need a strategy to let the refresh of Bloomberg data take about the right amount of time.
Currently, your program seems to allow only certain small amounts of time to pass with no feedback. Instead, you need to make a loop that cycles once every 10 seconds (or whatever makes sense) and checks to see if the program is done.
I like to do it this way:
dim count as integer
dim updated as boolean
updated = false
for count = 1 to 12 'or any value you choose
if updated = false then
if objApp.WorksheetFunction.CountIf(objApp.Range("rng_inWorkbook"),"#NAME?") = 0 Then
updated = true
else
Application.OnTime Now + TimeValue("00:00:15"), "WaitTillUpdateComplete"
end if
end if
next
Some background, I had a VBA loop creating PPT slides with various filters/views on an Excel pivot table. It was working (after I added DoEvents). I have recently added functionality to create a new PPT file from scratch with multiple sides before they are populated with the data. It's not working anymore.
Two theories:
1) Somehow the memory got bogged down in the new PPT file creation loop and now the data population loop is erroring out.
2) Something about how the default chart is formatted is messed up. If I edit the charts manually, save, and populate, there is no error. However if I create and then automatically try to populate, there's an error.
Due to complexity of the scripts, the loop to create the slides is completely separate from the loop to reopen and populate the slides.
Here's the section that errors out:
'Paste the final temp dataset into PPT
Range("A1000").Activate
tempdata = Range(Selection, Selection.Offset(months, categories - 1)).Value
Set oChart = oPres.Slides(pages(b)).Shapes(metrics(a)).Chart
oChart.ChartData.Activate
Set wb = oChart.ChartData.Workbook
Set ws = wb.Worksheets(1)
ws.Range("A1:Z1000").ClearContents
ws.Range("A1", Range("A1").Offset(months, categories - 1)).Value = tempdata
'Let code catch up
Application.Wait (Now + TimeValue("00:00:02"))
DoEvents
'Redraw the selected dataset of the chart based on the # of categories and rows
oChart.SetSourceData Source:="='Sheet1'!$A$1:" & toChar(categories + 0) & months + 1, PlotBy:=xlColumns
Despite using both Application.Wait and DoEvents, it is still hanging up.
This is purely a timing issue because if I click Debug and continue running the code with no changes, it works fine. I am also using late binding (maybe?) through the Set Object statement and at the end of the loop I always Set oChart = Nothing.
Sometimes it works to write DoEvents multiple times, but as the process has gotten more complex, even this doesn't work. I'm all out of ideas. Any suggestions?
'Let code catch up
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
DoEvents
'Redraw the selected dataset of the chart based on the # of categories and rows
oChart.SetSourceData Source:="='Sheet1'!$A$1:" & toChar(categories + 0) & months + 1, PlotBy:=xlColumns
You may try:
Using Sleep, with this line at the top of your module (outside of your function):
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Then add this line in place of, or in addition to, DoEvents:
Sleep 1 ' Pause for 1 ms
See:
https://stackoverflow.com/a/3891017/2707864
See also:
https://www.myonlinetraininghub.com/pausing-or-delaying-vba-using-wait-sleep-or-a-loop
Using loops with DoEvents:
Dim PauseTime, Start, Finish, TotalTime
PauseTime = 4 ' Set duration.
Start = Timer ' Set start time.
Do While Timer < Start + PauseTime
DoEvents ' Yield to other processes.
Loop
Finish = Timer ' Set end time.
TotalTime = Finish - Start ' Calculate total time.
See:
https://www.mrexcel.com/forum/excel-questions/36052-when-how-use-doevents-solved-post166114.html#post166114
See also:
https://www.myonlinetraininghub.com/pausing-or-delaying-vba-using-wait-sleep-or-a-loop
Using combinations thereof, which can improve performance of your system depending on the wait time.
Public Sub WaitSeconds(intSeconds As Integer)
On Error GoTo PROC_ERR
Dim datTime As Date
datTime = DateAdd("s", intSeconds, Now)
Do
Sleep 100
DoEvents
Loop Until Now >= datTime
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , "modDateTime.WaitSeconds"
Resume PROC_EXIT
End Sub
See:
http://www.fmsinc.com/microsoftaccess/modules/examples/avoiddoevents.asp
#sancho.s, thanks for your help. So it turns out the error had nothing to do with DoEvents. I had been using that as a sloppy fix without understanding its functionality. Given that, none of the three options worked. I spent all day trying various combinations with no success. Instead, I had to brute force close the embedded PPT workbook, set oChart to Nothing, reinstantiate oChart, reopen the workbook, and close it again.
This made the process 2x slower (but no slower than forcing it to wait on a timer??), and it completely eliminated all errors. Apparently it just didn't like pasting the raw data and reselecting the data the first time the workbook was opened. No idea why.
Sub UpdateChart(ByVal a As Integer, ByVal b As Integer, ByVal months As Integer, ByVal categories As Integer, ByRef pages() As Integer, ByRef metrics() As String, ByVal oPres As Object, ByVal legend_flag As Boolean)
Dim tempdata As Variant
'Paste the final temp dataset into PPT
tempdata = Range(Worksheets("calc").Range("A1000"), Worksheets("calc").Range("A1000").Offset(months, categories - 1)).Value
If legend_flag Then
Set oChart = oPres.Slides(pages(b)).Shapes("legend").Chart
Else
Set oChart = oPres.Slides(pages(b)).Shapes(metrics(a)).Chart
End If
oChart.ChartData.Activate
Set wb = oChart.ChartData.Workbook
Set ws = wb.Worksheets(1)
ws.Range("A1:Z1000").ClearContents
ws.Range(ws.Range("A1"), ws.Range("A1").Offset(months, categories - 1)).Value = tempdata
'Close workbook
wb.Close
Set oChart = Nothing
If legend_flag Then
Set oChart = oPres.Slides(pages(b)).Shapes("legend").Chart
Else
Set oChart = oPres.Slides(pages(b)).Shapes(metrics(a)).Chart
End If
oChart.ChartData.Activate
'Redraw the selected dataset of the chart based on the # of categories and rows
oChart.SetSourceData Source:="='Sheet1'!$A$1:" & toChar(categories + 0) & months + 1, PlotBy:=xlColumns
'Close workbook
oChart.ChartData.Workbook.Close
Set oChart = Nothing
Exit Sub
End Sub
I also put the code snippet in a subroutine and added Exit Sub at the end to hard reset all parameters in an earlier attempt that didn't work. So all objects and parameters have definitely been cleared for good measure.
Does anyone have any ideas why the object definition/open workbook was tripping up like that? And why DoEvents doesn't actually work for this problem?
I am writing code to create a template. This code populates a tab named "fullDistribution" from user-input on different tabs in the same wb. I have a working section of code that I wrote in a separate module (for testing) away from my master module. The code runs properly and executes completely when it is separate. When I pasted this section of code into my master module and ran it, I began receiving "Run-time error 91: object variable or with block variable not set" at the start of the newly-pasted code. I am not using any with blocks, and all of my variables are set. I made no changes in my code when I transferred it to my master module, and I carried over the new variables I created.
This is the selection of code that I wrote in a separate module:
Worksheets("bls2016").Activate
tcount = WorksheetFunction.CountA(Worksheets("detailedEntity").Range("D2:D" & Cells(Rows.Count, "D").End(xlUp).Row))
acount = WorksheetFunction.CountA(Worksheets("detailedEntity").Range("K2:K7"))
Application.ScreenUpdating = False
Dim h As Integer
Dim f As Integer
Dim blstate As Range
Dim bl As Range
Dim state As Range
Dim deat As Range
Dim agje As Range
Dim e As Integer
Dim r As Integer
Dim ii As Integer
Set blstate = Worksheets("bls2016").Range("D2:D" & Cells(Rows.Count, "D").End(xlUp).Row)
Set state = Worksheets("detailedEntity").Range("Q1")
Set deat = Worksheets("detailedEntity").Range("D2:D" & Cells(Rows.Count, "D").End(xlUp).Row)
Set agje = Worksheets("detailedEntity").Range("L2:M" & Cells(Rows.Count, "M").End(xlUp).Row)
h = Activecolumn
f = Activerow
r = 2
x = 120
For e = 1 To (acount * acount)
blstate.Find(state).Select
For ii = 1 To x
'ccnt = acst.Offset(0, 1)
ccgv = ActiveCell.Offset(0, 2)
acem = ActiveCell.Offset(0, 5)
Do While True
vl1 = Application.IfNa(Application.VLookup(Worksheets("fullDistribution").Cells(r, 2), deat, 1, False), 0)
If vl1 = 0 Then
Worksheets("fullDistribution").Cells(r, 4) = 0
Else:
vl2 = Application.IfNa(Application.VLookup(Worksheets("fullDistribution").Cells(r, 1), agje, 2, False), 0)
If ActiveCell.Offset(0, 1).Value = "Unknown Or Undefined" Then
Exit Do
Else:
If vl2 = ccgv Then
Worksheets("fullDistribution").Cells(r, 4) = acem
ElseIf vl2 <> ccgv Then
Worksheets("fullDistribution").Cells(r, 4) = ActiveCell.Offset(x + 1, 5)
Else:
End If
End If
End If
Exit Do
Loop
ActiveCell.Offset(f + 1, h).Select
r = r + 1
Next ii
Next e
The error triggers at the line "blstate.find(state).select" which tells excel to look in a dynamic range that contains the names of states and select the first instance of the state to use as the Activecell. Again, this works when it's run outside of the main module.
I believe this has something to do with a reference area. When this runs alone and finishes, I have to have a specific worksheet activated for it to run properly. If my excel workbook is open to a different tab, it will not run. My main module too only executes properly if it is run on a specific worksheet/tab.
If need be, I can edit my post and provide my whole master code.
It may be a problem of not fully referencing sheets, eg amend your blstate line to
with Worksheets("bls2016")
Set blstate = .Range("D2:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
end with
Then it might find the value and not error. You should look up how to use the Find method as your way is destined to cause you headaches.
blstate.Find(state).Select
Your code assumes that .Find finds what it's looking for. When Find doesn't find what it's looking for, the function returns Nothing, which is essentially a null object reference - and you can't make member calls on Nothing without getting run-time error 91.
Split it up:
Dim result As Range
Set result = blstate.Find(state)
If Not result Is Nothing Then
result.Select 'questionable anyway, but that's another issue
Else
MsgBox "Value '" & state & "' was not found in " & blstate.Address(External:=True) & "."
Exit Sub
End If
As for why it's not finding what you're looking for, Tim Williams already answered that:
Find recalls all settings used in the last call (even if you use the GUI to perform the Find), so make sure you specify the settings you want when you call it via VBA. If you don't do that, it may not work as you expect.... – Tim Williams 42 mins ago
My issue was very much related to incorrect referencing, however, I was able to resolve this issue by keeping the specific piece of code I was testing in a separate sub, and calling it from my main code, 'full distribution'.
Call test
'test' is the name of the sub with the tested code. This is a temporary fix to the solution, and if anyone struggles with referencing, try this.
I read a data line from an instrument using Excel VBA.
I would like to plot the data dynamically on an Excel Active Chart, IMMEDIATELY after it has been read.
I need to wait and read the data every 5 seconds and, in the mean time, I "sleep", either through the VBA Application.Wait command, or through the Kernel32 Sleep command.
In either case the Active Chart does NOT get updated. The complete plot shows up only after the LAST "sleep".
Any suggestions will be appreciated.
Here is the simplified code
Sub New_Data(indx)
Dim x As Integer
While True
x = Read_Instrument(1)
y = Read_Instrument(2)
Cells(indx, 1) = x
Cells(indx, 2) = y
ActiveSheet.ChartObjects.Item(1).Activate
ActiveChart.FullSeriesCollection(1).XValues = "=Sheet1!$A$1:$A$" & indx
ActiveChart.FullSeriesCollection(1).Values = "=Sheet1!$B$1:$B$" & indx
indx = indx + 1
Sleep 5000 'Use the KERNEL32 Sleep function for 5000 milliseconds
Wend
End Sub
Wait and Sleep will keep VBA running, so the screen will not updated.
Try using Application.OnTime, along these lines (in a standard code module, i.e. Module1).
Sub refreshMyChart()
Dim indx as long: indx = sheet1.Cells(Rows.Count, 1).End(xlUp).offset(1)
Cells(indx, 1) = Read_Instrument(1)
Cells(indx, 2) = Read_Instrument(2)
With Sheet1.ChartObjects(1).FullSeriesCollection(1)
.XValues = "=Sheet1!$A$1:$A$" & indx
.Values = "=Sheet1!$B$1:$B$" & indx
End With
''''' Now Schedule the same routine for 5 seconds later''''''''''
Application.OnTime Now + TimeSerial(0,0,5), "refreshMyChart"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub
p.s.: be aware that this data cannot grow indefinitely.. You should define some way to stop or to delete old rows to keep the number of displayed data rows reasonable.
Excellent! Thank you very much.
I was not aware of the .OnTime construct
Application.OnTime Now + TimeSerial(0, 0, 5), "refreshMyChart"
and the fact that VBA allows recursive routines.
As for ending the loop, there is code in there, which I did not post because it was not relevant to the issue. Here it is
If Int(current_index / nmeasure) * nmeasure > finalval Then
MsgBox ("End of Measurement")
Exit Sub
End If
Thanks again.
In Word 2016 VBA I want to set the shading of each cell of a table with a loop.
This seems to work for tables up to a size of about 15*15. With tables such as 20*20 or larger Word does not respond any more. Program execution seems to be correct though when using single step. I tried this for tables of ca. 50*50. ScreenRefresh and ScreenUpdating seem to have no influence.
In the code example, setting the shading of each cell to the same background color is only for demonstration, finally I want to apply more complex settings.
Sub TableCells_SetBackgroundColors()
' Set background color for each cell in Word table
' Application does not respond if table is larger than about 20*20
' debug single step works in any case
'Application.ScreenUpdating = False
Dim i, k, cntCol, cntRow As Integer
cntCol = 15 ' 20 is not ok
cntRow = 15 ' 20 is not ok
If ActiveDocument.Tables.Count <> 0 Then
ActiveDocument.Tables(1).Delete
End If
ActiveDocument.Tables.Add Range:=Selection.Range, _
numRows:=cntRow, _
NumColumns:=cntCol
Dim myTable As Word.Table
Set myTable = Selection.Tables(1)
With myTable.Borders
.InsideLineStyle = wdLineStyleSingle
.OutsideLineStyle = wdLineStyleSingle
End With
For i = 1 To cntRow Step 1
For k = 1 To cntCol Step 1
myTable.Cell(i, k).Shading.BackgroundPatternColor = wdColorRed
'Application.ScreenRefresh
Next k
Next i
'Application.ScreenUpdating = True
End Sub
Intro: The guy who commented here. Your problem occurs because the execution of the code takes to long doing stuff where to application itself doesn't do any events as far as I know. If this takes longer then a specific timespan the application just says it's not responding anymore. On my machine for example the application doesn't respond anymore even with only 15 rows and columns. There is one method that prevents this from happening: DoEvents. Below is your code with 3 more lines I added which works georgously on my machine. Below the code is a little more explanation.
Sub TableCells_SetBackgroundColors()
' Set background color for each cell in Word table
' Application does not respond if table is larger than about 20*20
' debug single step works in any case
'Application.ScreenUpdating = False
Dim i, k, cntCol, cntRow As Integer
cntCol = 21 ' 20 is not ok
cntRow = 21 ' 20 is not ok
If ActiveDocument.Tables.Count <> 0 Then
ActiveDocument.Tables(1).Delete
End If
ActiveDocument.Tables.Add Range:=Selection.Range, _
numRows:=cntRow, _
NumColumns:=cntCol
Dim myTable As Word.Table
Set myTable = Selection.Tables(1)
With myTable.Borders
.InsideLineStyle = wdLineStyleSingle
.OutsideLineStyle = wdLineStyleSingle
End With
For i = 1 To cntRow Step 1
'New
Application.StatusBar = "Row " & i & " of " & cntRow
'New
For k = 1 To cntCol Step 1
'New and important
DoEvents
'New and important
myTable.Cell(i, k).Shading.BackgroundPatternColor = wdColorRed
Next k
Next i
'New
Application.StatusBar = False
'New
End Sub
More Explanation: So for some reason Word is very slow with looping through all the cells of a table and applying some shading to them. This triggers the behaviour I described above. To prevent the application from not responding I inserted the line DoEvents in your column loop, so that the application "realizes that it is still alive" during every cell iteration. I did not test how much of an performance cost the DoEvents method has in this case but if you find it to be significant you can try to move DoEvents to the row loop and see if you are still fine. As for the other two lines with the StatusBar, these are not necessary to prevent the application from not responding but I find them very usefull because they prevent the user/you/me from worrying that the application crashed. It will tell you in the statusbar in which row the code currently is.
The statusbar during execution:
#Xam Eseerts
Thank you for your answer which solves the problem.
(It is still surprising how slow Word seems to work here. For my task of creating a big colorful table I finally switched to Excel).