I have some code at the moment to draw a graph based on the values of a series of text boxes on an access form.
I’m happy with the code and how it works but I’m not convinced that it is the most efficient way of doing this. The graph takes about 1.2 seconds to redraw each time. The form is unbound so it is just getting the values from the text boxes. Just to check I got it to loop through and dump the text boxes values to debug.print and that did it instantly so it cant be that.
I suspect that it is trying to redraw the graph after each value is added. Is there a quicker way of doing this in VBA or am I stuck with it?
'**************************
'** Draw the Call Deviation graph **
'**************************
.cells(1, 1) = "Start Time"
.cells(1, 2) = "Deviation"
lRT_actual = 0
lRT_forecast = 0
For i = 1 To 48
lRT_actual = lRT_actual + Me.Controls("txtActual_" & i)
lRT_forecast = lRT_forecast + Me.Controls("txtForecast_" & i)
.cells(i + 1, 1) = Format(DateAdd("n", (i - 1) * 15, "08:00:00"), "HHMM")
.cells(i + 1, 2) = lRT_actual - lRT_forecast
If Me.acxProgress_bar.Value + 2 < 100 Then
Me.acxProgress_bar.Value = Me.acxProgress_bar.Value + 2
Else
Me.acxProgress_bar.Value = 90
End If
Next i
Thanks for your help
Would it be possible for you to add the values to a table and graph that?
Related
Let's say I have four data values and one of them exists sometimes.
My For loop crashes because the path doesn't exist.
I would like to pass a "" in the cell instead of crashing.
myJSON.data[i].bank[0].money <- this part is my problem, because the bank[0].money sometimes doesn't exist.
I would like to keep the cell empty.
I tried an If but I didn't get it formatted properly, same goes for error handling.
Sub DATA()
Set RDict = CreateObject("Scripting.Dictionary")
Set dlist = CreateObject("Scripting.Dictionary")
JSON_String = Form.fromURL("exampleurl")
With CreateObject("htmlfile")
With .parentWindow
.execScript "var myJSON = " & JSON_String & ", csvstring = '';for (i = 0; i < myJSON.data.length; i++) {csvstring += myJSON.data[i].name + ',' + myJSON.data[i].bank[0].money + ',' + myJSON.data[i].location + ',' + myJSON.data[i].planneddate + ';';};"
RData = Split(.csvstring, ";")
End With
End With
For i = 0 To UBound(RData) - 1
DaData = Split(RData(i), ",")
If DaData(0) <> "null" Then RDict(DaData(0)) = DaData
Next i
Dim RSheet() As Variant
If RDict.Count > 0 Then
ReDim RSheet(2 To RDict.Count + 2, 1 To 7)
i = 0
For Each D In RDict
datalist(RDict(Da)(2)) = True
For j = 0 To 6
RSheet(i + 2, j + 1) = RDict(Da)(j)
Next j
i = i + 1
Next Da
RSData.Cells(2, 1).Resize(i, 6) = RSheet
End If
End Sub
You can handle null by using optional chaining with default nullish coalescing (#3 in example).
Something like this should work
Change myJSON.data[i]?.bank[0]?.money
To myJSON.data[i]?.bank[0]?.money ?? 'Unknown'
You can do the same with your other variables (myJSON.data[i].location and myJSON.data[i].planneddate) if they have the potential to be undefined or null as well
EDIT - Use Optional IF when optional chaining is not available
If that feature is not available in HTMLDocument's javascript maybe you can use basic conditional if?
This should work for undefined object, because undefined is == null
(myJSON.data[i].bank[0].money != null ? myJSON.data[i].bank[0].money : '-')
I have two worksheets, Receiving and Order Archive, both of which have tables on them with the same headers: sku, qty, Patient Name, Product Info, Vendor, L/R, Clinician, Date Ordered, PO Number, Received, Cost
.
I'm trying to write a macro that starts on receiving page table, and pulls all the rows found on the Order Archive sheet table named "OrderArchive", copies that row information onto "Receiving" table. However I only want it to pull ones that are designated in the Received column as "[Pending]".
Usually don't like to hand code out without any effort on your end, but give this a try and let me know if it's what you're looking for:
'I named the Receiving tab's table "receivingTable"
'I named the Order Archive tab's table "orderArchiveTable"
Dim cnt As Integer
Dim x As Integer
Dim y As Integer
Dim cntPending As Integer
Dim myArray() As Variant
'count number of rows that are in orderArchiveTable
cnt = Range("orderArchiveTable").Rows.Count
'Scan orderArchiveTable for 'Pending' Orders in the 'Received' column
cntPending = 0
For x = 1 To cnt
'count number of row that are Pending to use for array size
If Range("orderArchiveTable[Received]")(x).Value = "Pending" Then
cntPending = cntPending + 1
End If
Next x
If cntPending = 0 Then Exit Sub 'no pending orders
'ReDim array for correct size... remember that it starts at zero! NOT 1
ReDim myArray(cntPending - 1, 9)
'Fill array with values
y = 0
For x = 1 To cnt
If Range("orderArchiveTable[Received]")(x).Value = "Pending" Then
myArray(y, 0) = Range("orderArchiveTable[sku]")(x).Value
myArray(y, 1) = Range("orderArchiveTable[qty]")(x).Value
myArray(y, 2) = Range("orderArchiveTable[Patient Name]")(x).Value
myArray(y, 3) = Range("orderArchiveTable[Vendor]")(x).Value
myArray(y, 4) = Range("orderArchiveTable[L/R]")(x).Value
myArray(y, 5) = Range("orderArchiveTable[Clinician]")(x).Value
myArray(y, 6) = Range("orderArchiveTable[Date Ordered]")(x).Value
myArray(y, 7) = Range("orderArchiveTable[PO Number]")(x).Value
myArray(y, 8) = Range("orderArchiveTable[Received]")(x).Value
myArray(y, 9) = Range("orderArchiveTable[Cost]")(x).Value
'Not sure if you want to delete the rows taken, but you would do this here and subtract 1 from x and cnt
Selection.ListObject.ListRows(x).Delete
x = x - 1
cnt = cnt - 1
'go to next row in array
y = y + 1
End If
Next x
'count number of rows that are in receivingTable
cnt = Range("receivingTable").Rows.Count + 1
'Dump array into receivingTable
For x = 0 To UBound(myArray)
Set NewRow = Range("receivingTable").ListObject.ListRows.Add(AlwaysInsert:=True)
Range("receivingTable[sku]")(cnt + x).Value = myArray(x, 0)
Range("receivingTable[qty]")(cnt + x).Value = myArray(x, 1)
Range("receivingTable[Patient Name]")(cnt + x).Value = myArray(x, 2)
Range("receivingTable[Vendor]")(cnt + x).Value = myArray(x, 3)
Range("receivingTable[L/R]")(cnt + x).Value = myArray(x, 4)
Range("receivingTable[Clinician]")(cnt + x).Value = myArray(x, 5)
Range("receivingTable[Date Ordered]")(cnt + x).Value = myArray(x, 6)
Range("receivingTable[PO Number]")(cnt + x).Value = myArray(x, 7)
Range("receivingTable[Received]")(cnt + x).Value = myArray(x, 8)
Range("receivingTable[Cost]")(cnt + x).Value = myArray(x, 9)
Next x
For my form, almost all paper forms should come with an ID that you enter into one field. However, a few forms will come with no IDs, and I want to generate into a different field an ID number based on the user entering the information.
What I want it to do is to create a 4-digit number, where the first digit is from the field usernum, and the last 3 digits are just sequentially counting.
The first time they press the button, nothing is in the usernum field yet, and I think this may be the cause of my runtime 94 error?
below is my code and the error line
Private Sub Command100_Click()
'on click of button InsightId is generated
Me.idnum = NewInsightID()
End Sub
Public Function NewInsightID() As Long
Dim lngNextID As Long
'Find highest ID in the test table and add 1
lngNextID = (Me.usernum * 1000) + DMax([idnum], "test", "usernum=" & Me.usernum) + 1
'ABOVE IS THE LINE WITH ERRORS
'Assign function the value of the Next ID
NewInsightID = lngNextID
End Function
I have tried various workarounds but none have worked
below is what i've tried and hasn't worked:
lngNextID = (Me.usernum * 1000) + 1 + NZ(DMax([idnum], "test", "usernum=" & Me.usernum),0)
lngNextID = (Me.usernum * 1000) + 1 + Nz(DMax([idnum], "test", "usernum=" & Nz(Me.usernum, 0)), 0)
lngNextID = (Me.usernum * 1000) + 1 + DMax([idnum], "test", "usernum=" & Nz(Me.usernum, 0))
EDIT 2:
Okay, have made process. Sort of have it working, except for two things--for some reason it won't start at 001, only 002. After that, it does move incrementally by one.
The main thing is an error if usernum is blank. Again, I don't anticipate this ever being the case, but when it comes to data entry I think it's best to assume the dumbest possible users, and since I'm going to be on vacation when this database is used I don't want to get any calls about errors. I'm trying to do it so that if usernum is blank, they get a message that tells them the error and cancels the sub, but for some reason it isn't working, and then later in the code i get the error message Run time error 3075 missing operator in query expression 'usernum='. I assumed doing a message box to fix that would solve the problem, but I can't get the message box to work.
Private Sub Command100_Click()
'on click of button InsightId is generated
If usernum = Null Then
Beep
MsgBox ("you cannot leave usernum blank")
Cancel = True
Else: Me.idnum = NewInsightID()
End If
End Sub
Public Function NewInsightID() As Long
Dim lngNextID As Long
'Find highest ID in the test table and add 1
If DMax("idnum", "test", "usernum=" & Me.usernum) = Null Then
lngNextID = (Me.usernum * 1000 + 1)
Else:
lngNextID = 1 + Nz(DMax("idnum", "test", "usernum=" & Me.usernum), Me.usernum * 1000 + 1)
End If
'Assign function the value of the Next ID
NewInsightID = lngNextID
End Function
EDIT3:
aaah I solved it incredible!!
Private Sub Command100_Click()
'on click of button InsightId is generated
If IsNull(Me.usernum) Then
Beep
MsgBox ("you cannot leave usernum blank")
Cancel = True
Else: Me.idnum = NewInsightID()
End If
End Sub
Public Function NewInsightID() As Long
Dim lngNextID As Long
'Find highest ID in the test table and add 1
If DMax("idnum", "test", "usernum=" & Me.usernum) = Null Then
lngNextID = (Me.usernum * 1000 + 1)
Else:
lngNextID = 1 + Nz(DMax("idnum", "test", "usernum=" & Me.usernum), Me.usernum * 1000)
End If
'Assign function the value of the Next ID
NewInsightID = lngNextID
End Function
This one is close:
lngNextID = (Me.usernum * 1000) + 1 + NZ(DMax([idnum], "test", "usernum=" & Me.usernum), 0)
but the first parameter of DMax (the fieldname or expression) is a string too:
lngNextID = (Me.usernum * 1000) + 1 + NZ(DMax("idnum", "test", "usernum=" & Me.usernum), 0)
I am trying to import data to a table. Basically its a MCQs. All my questions are having superscripts and subscripts, for example X2 , and log52....
I have more than 2000 records, i have to import it. But after importing it comes in plain format, not taking powers. My DB is MYSQL (UTF-8)
Here is the example data
If log5 2, log5 (2x - 5) and log 5(2x - 7/2) are in AP , then x is equal to
after impoting it looks like above, but actually it should be
If log5 2, log5 (2x - 5) and log 5(2x - 7/2) are in AP , then x is equal to
Somebody plz suggest me how to do it
Here's a quick fix for the Subscripts:
Sub log_Script()
Dim cel As Range, rng As Range
Dim i&, k&
Dim myText$, findText$, curStr$
Set cel = Range("A1")
'myText = cel.Value
For i = 1 To Len(cel.Value)
k = k + 1
curStr = Mid(cel.Value, i, 1)
If curStr <> " " Then
findText = findText + curStr
ElseIf curStr = " " Then
findText = ""
End If
Debug.Print findText
If findText = "log" Then
If Mid(cel.Value, i + 1, 1) = " " Then
With cel.Characters(Start:=k + 2, Length:=1).Font
.Subscript = True
End With
Else
With cel.Characters(Start:=k + 1, Length:=1).Font
.Subscript = True
End With
End If
End If
Next i
End Sub
This will go through a range (set currently to be A1:A10), and for each cell, it'll look for log then take the next number and make it subscript. (Note: This is assuming all logs will have base < 10, let me know if that's not necessarily the case).
I could probably make this better, if you can post a few rows or cells from your CSV so I can see what the formatting is exacly like. (Or screenshot a part of your data, that 'd work too).
I use a Chart to Display Progress of Activity on ms-access 2007 with VBA, I used to work with PivotCharts wich was fast but not really editable. I need to only display the past months and make invisibles points for the rest of the year.
My Chart is display with 2 Series of 300 points (granularity increased), but I only show Data Labels once in a month.
I wasn't able to edit point by point with Pivot Chart so I moved to a classic oldStyle Chart.
My problem is that my edit is very slow, I've read about many things about VBA optimization but nothing done the trick
I measured 20 seconds for each curve it's not "acceptable" for my hierarchy.
I was thinking about multi-threading but it's way too much work for a so small benefit (%4? or %8?)
(FYI Calculation of points and so on is done before the opening of the Form and is doing great)
Here is my code of this Slow Chart Edition :
Dim intPntCount As Integer
Dim intTmp As Integer
Dim oSeries As Object
Dim colSeries As SeriesCollection
Dim oPnt As Object
Dim intCptSeries As Byte
Dim booPreviousZero As Boolean
Dim startDate, endDate As Date
Dim lngWhite, LngBlack As Long
lngWhite = RGB(255, 255, 255)
LngBlack = RGB(0, 0, 0)
linPlanned.BorderColor = RGB(251, 140, 60)
linCompleted.BorderColor = RGB(52, 84, 136)
lblUnit.Left = 1248 'use fctgetabsciisa chProgressFixs.Axes(2).MaximumScale / 80
With Me.chProgressFixs
startDate = Now
.BackColor = lngWhite
intCptSeries = 0
'colSeries = .SeriesCollection
For Each oSeries In .SeriesCollection
intCptSeries = intCptSeries + 1
Debug.Print "Series" & intCptSeries
booPreviousZero = True
intPntCount = 1
For Each oPnt In oSeries.Points
oPnt.ApplyDataLabels
If oPnt.DataLabel.Caption = "0" Then
oPnt.Border.Weight = 1
oPnt.DataLabel.Caption = vbNullString
If booPreviousZero = False Then
oPnt.Border.Color = lngWhite
booPreviousZero = True
Else
oPnt.Border.Color = LngBlack
End If
Else
booPreviousZero = False
oPnt.Border.Weight = 4
oPnt.DataLabel.Font.Size = 14
Select Case intCptSeries
Case 1: oPnt.Border.Color = linPlanned.BorderColor
Case 2: oPnt.Border.Color = linCompleted.BorderColor
End Select
If ((intPntCount + 30) / 30 <> Int((intPntCount + 30) / 30)) Then
If (intPntCount < oSeries.Points.Count) Then
If (intPntCount <> IntLastDispDay - 1) Then
oPnt.DataLabel.Caption = vbNullString
Else
oPnt.DataLabel.Font.Size = 20
End If
End If
End If
End If
intPntCount = intPntCount + 1
Next
Debug.Print DateDiff("s", startDate, Now)
Next
Me.TimerInterval = 1
End With
Thanks all for your help
Maybe you need to avoid screen refresh with:
Application.ScreenUpdating = False
and then
Application.ScreenUpdating = true
when finished. It also be helpful if you use \ insted of / when dividing, if you don't care about working only with integers. Try it.
Maybe you should replace:
If ((intPntCount + 30) / 30 <> Int((intPntCount + 30) / 30)) Then
with something like
If (((intPntCount + 30) MOD 30) > 0 ) Then
and measure the time of execution. Another thing about your code is that:
oPnt.DataLabel.Font.Size = 14
...maybe should be inside the if's trying to avoid rewrite the property two times. Try something like:
If (((intPntCount + 30) MOD 30) > 0 ) Then
If (intPntCount < oSeries.Points.Count) Then
If (intPntCount <> IntLastDispDay - 1) Then
oPnt.DataLabel.Caption = vbNullString
oPnt.DataLabel.Font.Size = 14
Else
oPnt.DataLabel.Font.Size = 20
End If
Else
oPnt.DataLabel.Font.Size = 14
End If
Else
oPnt.DataLabel.Font.Size = 14
End If
Even it would be a very very little improvement to precalculate
(intPntCount + 30)
in a variable after
intPntCount = intPntCount + 1
...and use something like:
dim intPntCountSum= 0
(...)
End If
intPntCount = intPntCount + 1
intPntCountSum=intPntCount + 30
Next
Finally, if you don't need the debug info, it would be a good thing to delete the lines:
Debug.Print "Series" & intCptSeries
and
Debug.Print DateDiff("s", startDate, Now)
I hope it help.