The following code is working fine, however it is not rounding the stored values to the nearest pence, for example 8.025 is coming up instead of 8.01 can anyone suggest a fix?
Public Function Fs_Update_AccInvoices_Nexum() As Boolean
Dim adoRsInvoiceDCID As New ADODB.Recordset
Dim adoRsNexumInvoices As New ADODB.Recordset
On Error Resume Next
adoRsInvoiceDCID.Open "SELECT * FROM [tInvoiceDCID] where Issued=0" _
, CurrentProject.Connection, 2, 2
While Not adoRsInvoiceDCID.EOF
adoRsNexumInvoices.Open "SELECT * FROM [tPrintInvoiceNumbersNexum] " _
& " WHERE InvoiceID=" & adoRsInvoiceDCID("InvoiceID") _
, CurrentProject.Connection, 2, 2
If Not adoRsNexumInvoices.EOF Then
DoCmd.SetWarnings off
DoCmd.RunSQL "Update [Acc Invoices t Nexum] " _
& " SET [Total Due] = Round((Fees/0.8)+(VAT/0.8)+OutLays,2)" _
& " Fees = Round(Fees/0.8,2), VAT = Round(Vat/0.8,2)" _
& " WHERE Invoice=" & adoRsNexumInvoices("PrintingasINVOICE")
End If
adoRsNexumInvoices.Close
adoRsInvoiceDCID.MoveNext
Wend
adoRsInvoiceDCID.Close
End Function
Cheers
Ross
Quick note:
I've noticed some inaccuracies in vba's rounding function which the format function doesn't fix. In my particular case, I was trying to round the number 3687.23486
round(3687.23486) = 3687.23
format(3687.23486, "#.00") = 3687.23
under the traditional round to nearest rules, this should result in 3687.24
I've seen several custom functions posted to various forums to address rounding problems, but none worked for me, so I wrote my own.
Function trueRound(ByVal varNumber As Variant, ByVal intDecimals As Integer) As Double
If IsNull(varNumber) Then
trueRound = 0
Exit Function
End If
Dim decimals As Integer, testNumber As Double
decimals = 0
If InStr(varNumber, ".") > 0 Then decimals = Int(Len(varNumber)) - Int(Len(Fix(varNumber)) + 1)
If decimals = 0 Or intDecimals > decimals Then
trueRound = varNumber
Exit Function
End If
Do Until Len(varNumber) - Len(Fix(varNumber)) - 1 <= intDecimals
testNumber = varNumber * 10 ^ (decimals - 1)
varNumber = Round(testNumber, 0) / 10 ^ (decimals - 1)
decimals = decimals - 1
Loop
trueRound = varNumber
End Function
I hashed it out pretty quick, so there's no error handling, and a null value passed to the function results in 0, which may not be ideal for all situations. I use this regularly in some pretty large queries, hope it can help someone else.
"The Round function performs round to even, which is different from round to larger."
--Microsoft
Debug.Print Round(19.955, 2)
'Answer: 19.95
Debug.Print Format(19.955, "#.00")
'Answer: 19.96
See also How to Round in MS Access, VBA
Related
I am updating an Access 2013 table through VBA. My task requires certain records to be added to the table during a loop and subsequently records to be read from the (updated) table. I am finding that my code works as expected provided I run through the code line by line in debug mode. However, if I run the code using F5, my results will be unpredictable. Sometimes the code works as expected and other times the loop finishes early. It looks as though the newly added records are not found by a select query, even though they have been added to the table. Referring to the code below, the INSERT INTO statement at the bottom is executed, but the subsequent opening of the adrsb recordset sometimes does not find the updated records, causing the loop to terminate early. I've been stumped on this for days now despite my best efforts in debugging. Any help will be very gratefully received. :)
Do
i = i + 1
'Debug.Assert i <> 4
If adrsb.State = 1 Then
adrsb.Close
Set adrsb = Nothing
Set adrsb = New ADODB.Recordset
adrsb.ActiveConnection = CurrentProject.Connection
adrsb.CursorType = adOpenStatic
End If
'adrsb.CursorType = adOpenDynamic
adrsb.Open "SELECT tblInScopeRestructures.Code1, tblInScopeRestructures.Gen " & _
"FROM tblInScopeRestructures " & _
"GROUP BY tblInScopeRestructures.Code1, tblInScopeRestructures.Gen " & _
"HAVING (((tblInScopeRestructures.Gen)=" & i & "))" & _
"ORDER BY tblInScopeRestructures.Code1;"
adrsb.Requery
Dim adrsc As ADODB.Recordset
Set adrsc = New ADODB.Recordset
adrsc.ActiveConnection = CurrentProject.Connection
adrsc.CursorType = adOpenStatic
If Not adrsb.EOF Then
adrsb.MoveLast
adrsb.MoveFirst
End If
If adrsb.RecordCount <> 0 Then
adrsb.MoveFirst
'strPrevCode1 = adrsb.Fields("Code1")
Do While Not adrsb.EOF
strPrevCode1 = adrsb.Fields("Code1")
If adrsc.State = 1 Then
adrsc.Close
End If
adrsc.CursorType = adOpenStatic
adrsc.Open "SELECT tblRestructure.Code1, tblRestructure.Code2, tblRestructure.RecDate " & _
"FROM tblRestructure " & _
"WHERE (((tblRestructure.Code2)='" & strPrevCode1 & "'));"
If adrsc.RecordCount <> 0 Then
adrsc.MoveFirst
Do While Not adrsc.EOF
adConn.Execute ("INSERT INTO tblInScopeRestructures(Code1,Code2,RecDate,Gen) VALUES ('" & adrsc.Fields("Code1") & "','" & adrsc.Fields("Code2") & _
"',#" & Format(adrsc.Fields("RecDate"), "mm/dd/yyyy") & "#," & i + 1 & ")")
Debug.Print adrsc.Fields("Code1") & adrsc.Fields("Code2")
Debug.Print i + 1
For j = 1 To 100000
Next j
adrsc.MoveNext
Loop
End If
adrsb.MoveNext
If adrsc.State = 1 Then
adrsc.Close
End If
Loop
End If
Debug.Assert adrsb.RecordCount <> 0
Loop While adrsb.RecordCount <> 0
I reckon the problem is probably here
adrsb.CursorType = adOpenStatic
change it to
adrsb.CursorType = adOpenDynamic
And Instead of this bit of code:
For j = 1 To 100000
Next j
You could try something slightly less thrashy such as:
DoEvents
And maybe after the DoEvents command, you could try adding a Requery command on your ADODB recordset.
Except you will probably lose your desired cursor position, so before doing the Refresh, you can record the ID of your primary key in a variable and then find that cursor location in the recordset
intID = adrsb.Fields("MyKey")
adrsb.Requery
rs.Find "MyKey = " & intID
Ok, I've got a solution of sorts. I inserted the following code to cause a pause immediately after the second EXECUTE INTO operation:
TWait = Time
TWait = DateAdd("s", 5, TWait)
Do Until TNow >= TWait
TNow = Time
Loop
This slows the code down very significantly, but it works. I experimented with shorter pauses but tended to get the same problems with the loop sometime exiting early. While the immediate problem is solved, I'm left a bit stunned that this is necessary and am worried about when such an issue will next raise its head.
I'm doing a Boolean comparison of a single precision number passed as an argument to a single precision field in a DAO recordset. The argument is 0.85 and the field is 0.85, yet VBA says the first is less than the second. I've looked at these in the Watch window, in break mode, with Debug.Print statements and they show up as the same number everywhere. Yet VBA doesn't return TRUE when I compare A = B.
The pertinent code is below my signature.
TIA,
Keith
Dim SQL As String
SQL = "SELECT cmpAttainPct, cmpPayPct, cmpPayAmt" _
& " FROM tblCompPlans" _
& " WHERE [cmpPerson]=""" & DMName & """" _
& " AND [cmpPeriod]=""" & BiPeriod & """" _
& " ORDER BY [cmpAttainPct];"
Dim rsCompPlan As DAO.Recordset
Set rsCompPlan = db.OpenRecordset(SQL)
' Round the percent to two decimal places.
' Didn't use the VBA Round() function which uses Banker's rounding,
' That rounds .5 either up or down, whichever will result in
' an even number." (Microsoft Round() help)
' I.E.: .645 = .64 and .655 = .66
' This does standard 4/5 rounding.
AttainPct = Int(AttainPct * 1000) / 1000
Dim ThousandsPlaceValue As Single
ThousandsPlaceValue = (AttainPct * 100) - Int((AttainPct * 100))
AttainPct = (Int(AttainPct * 100) / 100)
AttainPct = AttainPct + IIf(ThousandsPlaceValue < 0.5, (-0.01), (0.01))
...
Do Until .EOF
Debug.Print AttainPct & " attainment equals " & !cmpAttainPct & " comp tier (" & (AttainPct = !cmpAttainPct) & ")"
Select Case True
Case (AttainPct < !cmpAttainPct)
TempAmt = PrevAmt
TierFound = True
.MoveLast
Case (AttainPct = !cmpAttainPct)
' Equal - tier found.
TempAmt = !cmpPayAmt
TierFound = True
.MoveLast
Case Else
PrevAmt = !cmpPayAmt
End Select
First, never use Single for calculations except if there is a very specific and good reason for doing so. If Currency can hold your values (four decimals maximum) use, else Decimal, and Double as the last option.
Second, Int does not do a 4/5 rounding, it rounds down. The simplest bug-free and true 4/5 rounding towards zero you can do, is with Format:
RoundedValue = CCur(Format(ValueToRound, "0.00"))
For a full set of rounding functions, see:
CodeProject: Rounding Values
or:
Experts-Exchange: Rounding values
With AttainPct rounded and converted to, say, Currency, you can reliably use:
Case (AttainPct < CCur(!cmpAttainPct))
and:
Case (AttainPct = CCur(!cmpAttainPct))
Computers are not very good at comparing floating point numbers for equality. Instead of
if a = b
use
if abs(a-b) < 0.0001
set the second part to as small as is necessary to make sure a small enough variation still counts as "equal".
I am trying to create a function which, after having search the entire active worksheet, will return the total number of cells that contain a certain string. A lot like how the "x cell(s) found" within Find and Replace works.
I have this so far:
Function FINDIST(stringToFind)
Dim counter As Integer: counter = 0
For Each Cell In ActiveSheet.UsedRange.Cells
If InStr (Cell, stringToFind) > 0
Then counter = counter + 1
End If
Next
End Function
Another way of doing this:
Function FINDIST(stringToFind) As Long
FINDIST = Evaluate("SUM(IFERROR(SEARCH(" & Chr(34) _
& "*" & stringToFind & "*" & Chr(34) & "," _
& ActiveSheet.UsedRange.Address & ",1),0))")
End Function
This searches for stringToFind in every cell in used range, and returns an array with a 1 if that string is found in a cell and error if it is not found. The error is casted to zero with the IFERROR part, and the SUM sums the resulting binary array.
This will count only once the occurrence of stringToFind within each cell, even if it occurs more than once, but looking at your code I assume that this is what you are looking for.
I hope it helps!
UPDATE
Out of curiosity, I did some testing to see how the two approaches compare (read from range directly vs using evaluate). Here is the code I used:
Option Explicit
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Sub test()
Dim ticks As Long
Range("A1:AA100000").Value = "adlrkjgalbabyajglakrjg"
ticks = GetTickCount
FINDIST1 ("baby")
Debug.Print "Read from range: ", GetTickCount - ticks
ticks = GetTickCount
FINDIST ("baby")
Debug.Print "Evaluate: ", GetTickCount - ticks
End Sub
Function FINDIST(stringToFind) As Long
FINDIST = Evaluate("SUM(IFERROR(SEARCH(" & Chr(34) _
& "*" & stringToFind & "*" & Chr(34) & "," _
& ActiveSheet.UsedRange.Address & ",1),0))")
End Function
Function FINDIST1(stringToFind) As Long
Dim counter As Long: counter = 0
Dim c As Range
Dim firstAddress As String
With ActiveSheet.UsedRange
Set c = .Find(stringToFind, LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
counter = counter + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
FINDIST1 = counter
End Function
UPDATE 2
Chris Nielsen made two very good points in the comments below:
ActiveSheet.Evaluate is faster than Application.Evaluate. The link to the text by Charles Williams in the comment explains this behavior.
Good old Variant array will perform better than any other method.
For completeness, I post the version of the variant array method that I tested:
Function FINDIST_looping(stringToFind) As Long
Dim vContents, lRow As Long, lCol As Long, lCounter As Long
vContents = ActiveSheet.UsedRange.Value2
For lRow = LBound(vContents, 1) To UBound(vContents, 1)
For lCol = LBound(vContents, 2) To UBound(vContents, 2)
lCounter = IIf(InStr(vContents(lRow, lCol), stringToFind), _
lCounter + 1, lCounter)
Next lCol
Next lRow
FINDIST_looping = lCounter
End Function
Doug Glancy made another very good point, namely that COUNTIF can be used instead of SEARCH. This leads to a non-array formula solution and should dominate my original formula, performance-wise.
Here is Doug's formula:
FINDIST_COUNTIF = ActiveSheet.Evaluate("COUNTIF(" _
& ActiveSheet.Cells.Address & "," & Chr(34) & "*" _
& stringToFind & "*" & Chr(34) & ")")
In fact, Doug's point implies that no Evaluate() is necessary. We can call Countif from the WorksheetFunction object. Therefore, if the goal is to call this function from a spreadsheet, there is no need to use Evaluate() or to wrap it up in a UDF - it is a typical COUNTIF application with wildcards.
Results:
Read from range: 247,495 ms (~ 4 mins 7 secs)
Application.Evaluate: 3,261 ms (~ 3.2 secs)
Variant Array: 1,706 ms (~ 1.7 secs)
ActiveSheet.Evaluate: 1,257 ms (~ 1.3 secs)
ActiveSheet.Evaluate (DG): 602 ms (~ 0.6 secs)
WorksheetFunction.CountIf (DG):550 ms (~ 0.55 secs)
It appears that Application.Evaluate is about 75 times faster compared to using Range.Find()(?!) Also, the original code (with Integer changed to Long) runs in ~8 seconds.
Also, it seems that Activesheet.Evaluate is actually faster than the Variant array in this particular case. The difference between calling CountIf as a WorksheetFunction method vs Evaluateing it seems quite small.
CAVEAT: the frequency by which stringToFind is found within the UsedRange might affect the relative performance of the several methods. I ran the Activesheet.Evaluate and Variant Array methods with the above range (A1:AA100000) but with only the ten first cells having the matching string.
Results (average of 6 runs, variance pretty much minimal):
Activesheet.Evaluate: 920 ms (~ 1. sec)
Variant Array: 1654 ms (~ 1.7 secs)
This is interesting - it seems that ActiveSheet.Evaluate in this case has a slightly better performance than variant arrays (unless I have done something horrible in the looping code, in which case please let me know). Also, the Variant method's performance is actually.. invariant with respect to the string's frequency.
runs were made on EXCEL 2010 under Win7.
Working with Tony Dallimore's advice of using Find and also changing your return type to Long.
MSDN article: http://msdn.microsoft.com/en-us/library/office/ff839746(v=office.15).aspx
Function FINDIST(stringToFind) As Long
Dim counter As Long: counter = 0
Dim c As Range
Dim firstAddress As String
With ActiveSheet.UsedRange
Set c = .Find(stringToFind, LookIn:=xlValues, , LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
counter = counter + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
FINDIST = counter
End Function
Find is generally quicker than a coded equivalent but I've not speed tested against anything else and will be interested to here if it is quick or slow.
I'm trying to set up a code in MS Access that increments the last four positions of a text field. The numbers in the text field have seven digits. For example:
0010012
0010013
First three digits represent the manuacturer and the last four the product. These are the ones I want to increment. I am using the code below, which I found online, and it is supposed to be working but I keep getting the error: "Run-time error '13': Type mismatch"
Dim varSifra As Variant
varSifra = DMax("[Sifra]", "tblProducts", "[Manufacturer] = " & Forms!frmProduct!Manufacturer)
Me.[Sifra] = Left(varSifra, 3) & Format(Val(Right(varSifra, 4)) + 1, "0000")
I tried the code without the Format function but instead of incremented number 0010014 I get 00114
Can this help?
Sub Test()
Debug.Print IncrementProduct("0010001") //Prints 0010002
Debug.Print IncrementProduct("0010012") //Prints 0010013
Debug.Print IncrementProduct("0010099") //Prints 0010100
End Sub
Function IncrementProduct(code As String) As String
Dim manufacturerCode As String, padding As String, productCode As String
manufacturerCode = VBA.Left$(code, 3)
productCode = CInt(VBA.Right$(code, Len(code) - Len(manufacturerCode))) + 1
padding = Application.WorksheetFunction.Rept("0", 4 - Len(productCode))
IncrementProduct = manufacturerCode & padding & productCode
End Function
You can use a simple Format call fine, however the input needs to be explicitly converted to a Long first:
Function IncProductNumber(Value)
If IsNull(Value) Then
Let IncProductNumber = Null
Else
Let IncProductNumber = Format(CLng(Value) + 1, "0000000")
End If
End Function
Or, more generically, the desired padding could be inferred from the input:
Function IncTextNumber(Value)
If IsNull(Value) Then
Let IncTextNumber = Null
Else
Let IncTextNumber = Format(CLng(Value) + 1, String$(Len(Value), "0"))
End If
End Function
IncTextNumber("0123") will produce "0124", IncTextNumber("00999") will produce "01000" and so on.
Dim tempManProd As String, tempNumToInc As Integer
tempManProd = 'get the value you are wanting to increment
tempNumToInc = CInt(right(tempManProd, 4))
tempNumToInc = tempNumToInc + 1
'This will make sure that the 0s get added back to the front of the product
Do While (Len(tempManProd & "") + Len(tempNumToInc & "")) < 7
tempManProd = tempManProd & "0"
Loop
tempManProd = tempManProd & CStr(tempNumToInc)
I'm trying to automate the following process using a Excel but I'm experiencing some difficulties as obviously I need to set up a variable within the OFFSET function:
Sheets("XXX").Visible = True
Sheets("XXX").Select
ActiveWorkbook.Names.Add Name:="XXX_aaa", RefersToR1C1:= _
"=OFFSET('XXX'!R2C1,0,1,COUNTA('XXX'!C1),21)"
Sheets("XXX").Visible = False
Sheets("YYY").Visible = True
Sheets("YYY").Select
ActiveWorkbook.Names.Add Name:="YYY_bbb", RefersToR1C1:= _
"=OFFSET('YYY'!R2C1,0,1,COUNTA('YYY'!C1),21)"
Sheets("YYY").Visible = False
Sheets("ZZZ").Visible = True
Sheets("ZZZ").Select
ActiveWorkbook.Names.Add Name:="ZZZ_ccc", RefersToR1C1:= _
"=OFFSET('ZZZ'!R2C1,0,1,COUNTA('ZZZ'!C1),21)"
Sheets("ZZZ").Visible = False`
Is there an easy macro function I can use to automate this task (it has to be repeated 30 times !)
Thanks !
Try this on a COPY of the workbook you are working with:
Sub Sample()
Dim intCurrentSheet As Integer
Dim lngLastRow As Long
For intCurrentSheet = 2 To 31
lngLastRow = Sheets(intCurrentSheet).Range("U1048576").End(xlUp).Row
Sheets(intCurrentSheet).Range("A2:U" & lngLastRow).Name = Sheets(intCurrentSheet).Name & _
"_" & Chr(intCurrentSheet + 63) & _
Chr(intCurrentSheet + 63) & _
Chr(intCurrentSheet + 63)
Sheets(intCurrentSheet).Visible = False
Next intCurrentSheet
End Sub