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".
Related
I need help at Auto-Incrementing a letter.
A description field in Table1 has values like: B39
This Table1 Record, has related records in Table2:
B39_a
B39_b
B39_c
B39_d
All I want to do is that the description in Table2 automatically takes the record at table1 and adds the specific letter. It always starts with "a" and never reaches the full alphabet.
I already tried some code from this site: http://www.freevbcode.com/ShowCode.asp?ID=5440
Function IncrementString(ByVal strString As String) As String
'
' Increments a string counter
' e.g. "a" -> "b"
' "az" -> "ba"
' "zzz" -> "aaaa"
'
' strString is the string to increment, assumed to be lower-case alphabetic
' Return value is the incremented string
'
Dim lngLenString As Long
Dim strChar As String
Dim lngI As Long
lngLenString = Len(strString)
' Start at far right
For lngI = lngLenString To 0 Step -1
' If we reach the far left then add an A and exit
If lngI = 0 Then
strString = "a" & strString
Exit For
End If
' Consider next character
strChar = Mid(strString, lngI, 1)
If strChar = "z" Then
' If we find Z then increment this to A
' and increment the character after this (in next loop iteration)
strString = Left$(strString, lngI - 1) & "a" & Mid(strString, lngI + 1, lngLenString)
Else
' Increment this non-Z and exit
strString = Left$(strString, lngI - 1) & Chr(Asc(strChar) + 1) & Mid(strString, lngI + 1, lngLenString)
Exit For
End If
Next lngI
IncrementString = strString
Exit Function
End Function
Apparently it is not working like it should. It increases the letter, but twice! (i , i , j , j , etc.)
Description textbox (for Table2 Record ) has as default value:
=IncrementString(DLast("[SeqNo]","[table2]"))
But like I said it increases the number by doing it double. I also have to start the process manually by entering an "a".
Neither the function nor the calling code presently allows for the "A##_" prefix. If you really MUST save this prefix to Table2, code would have to be adjusted to deal with it. As is, suggest not saving the "A##" group identifier as a prefix in Table2. Use a query that joins tables on PK/FK fields to retrieve related data for export.
The DLast() search must account for the "A##" group identifier because the sequence is repeated for each group.
Unfortunately, trying to set a DefaultValue property with a dynamic parameter dependent on main form ID is impractical. For one thing, subform loads before main form so the default value cannot be built since the main form data and controls are not available. Also, when the main form is moved to a new record, again there is no data for the default value to build with. The result is error displays for the control on new record row.
Use PK/FK fields for the search.
Code in subform Current event to call your incrementing function:
If Me.NewRecord And Not IsNull(Me.Parent.ReferenzNR) Then
Me!SerienBezeichnung = IncrementString(Nz(DLast("SerienBezeichnung", "tbl_GrundminenSerie", "ID_FK=" & Me.Parent.ReferenzID), ""))
End If
Be aware that DLast(), even though working now, could eventually fail because records do not have inherent order. An alternative would likely involve a recordset or nested domain aggregate. Example tested in VBA Immediate Window:
?DMax("SerienBezeichnung","tbl_GrundminenSerie","ID_FK=5 AND Len([SerienBezeichnung])=" & DMax("Len([SerienBezeichnung])","tbl_GrundminenSerie","ID_FK=5"))
Or if you feel autonumber PK can be depended on to always be increasing (which has always been my observation although there is no guarantee with autonumber):
?DLookup("SerienBezeichnung","tbl_GrundminenSerie","ID_FK=5 AND SerienID=" & DMax("SerienID","tbl_GrundminenSerie","ID_FK=5"))
Consider the following VBA function:
Function IncAlpha(ByVal strA As String, ByVal lngI As Long) As String
If lngI <= 0 Then
IncAlpha = strA
ElseIf strA = vbNullString Then
IncAlpha = IncAlpha("a", lngI - 1)
Else
lngI = lngI + Asc(Right(strA, 1)) - 97
IncAlpha = IncAlpha(Left(strA, Len(strA) - 1), lngI \ 26) & Chr(97 + lngI Mod 26)
End If
End Function
Supplied with a lowercase alphabetical string, this recursive function will increment the string by the supplied long integer argument, with z incrementing to aa, az incrementing to ba and so on.
Supplied with an empty string (""), the above function will return a.
?IncAlpha("", 1)
a
?IncAlpha("", 26)
z
?IncAlpha("", 27)
aa
?IncAlpha("", 42)
ap
?IncAlpha("", 314159)
qvsa
With this function, the suffix may therefore be calculated using:
<prefix> & IncAlpha("", DCount("[SeqNo]","[table2]") + 1)
Or to account for multiple prefixes:
<prefix> & IncAlpha("", DCount("SeqNo","table2","SeqNo like '" & <prefix> & "*'") + 1)
I looked around and had a hard time finding anything that helped let alone a canned solution to use. I needed to filter a listbox in realtime so my users could search every row / column for a term.
The listbox I had was unbound and I was using buttons that drove logic / code to call various queries that would populate the data in the listbox. Every button called a query with a different number of columns, so the listbox changed dynamically to display this information accordingly.
Since I had such a hard time finding anything about this issue, I decided to share my solution with all of you wonderful folks who have helped me with my development issues.
Please see the solution below
If you think I need to fix anything in the post, let me know and I'll update it to better explain.
One small thing to point out, is that I store the UNFILTERED recordset that was originally stored in the listBox to a global variable on the form. I set the textbox to have an "onChange" event trigger and call the function below with it. I pass in the listbox, the user String from the textbox, and the global variable I made for the unfiltered recordset. This is needed to get the original data back when characters are deleted.
Also, this function does not handle numeric columns well. I realized this after some testing with a Query that had numeric datatype columns. In order to step around this issue, I set the query to return the number as a string using the CStr() function. For our newbies, I simply went into the named query, found my numeric column, and put the Cstr in the "field row". So for example, I have a numeric column called "Customer Impacted". I went into the query, and wrote this on the 'field row' for the [customer's impacted column]:
Customers_Affected: Cstr([customers impacted])
I want to caution that you may experience lag if you have huge recordsets. I'm only using about a size of 3000 and it runs very nicely. Enjoy.
Function realTimeFilter(ByVal List As Listbox, ByVal userString As String, ByVal staticRecordSet As DAO.Recordset)
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'\\\ \\\
'\\\ This Function allows the user to input any string to create a \\\
'\\\ Filter on a given listbox in realtime. \\\
'\\\ \\\
'\\\ The programmer gives this fucntion the listbox of values to filter, \\\
'\\\ The user's input string, and the unfiltered recordset that should be \\\
'\\\ held in a global variable on the form. \\\
'\\\ \\\
'\\\ I personally create a global called baseRecord. Everytime I update \\\
'\\\ the records in the listbox with a new unfiltered set, \\\
'\\\ I clone a copy to baseRecord. This allows \\\
'\\\ the user to delete strings from the filter and regain the old dataset \\\
'\\\ without having to query the data to the box again. \\\
'\\\ \\\
'\\\ enjoy! \\\
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'declare variables
Dim rs As DAO.Recordset
Dim str() As String
Dim filterStr As String
Dim i As Integer
Dim k As Integer
'adds unfiltered recordset back to listbox and also puts the data into our set for manipulation
Set List.Recordset = staticRecordSet.OpenRecordset
Set rs = List.Recordset
'split the terms
str = Split(userString, ",")
'examine the textbox string after it has been parsed. Determine which set of logic to use:
'first set is for single search criteria. Second block is for multiple search criteria
If (UBound(str) = 0) Then
'loop through the column fields
For i = 0 To rs.Fields.Count - 1
'if not on last column add an "OR" to the end of the filter string. Else cap the string
If ((i < rs.Fields.Count - 2) Or (i = rs.Fields.Count - 2)) Then
filterStr = filterStr & " " & rs.Fields(i).Name & " like '" & Trim(str(0)) & "*' OR "
Else
filterStr = filterStr & " " & rs.Fields(i).Name & " like '" & Trim(str(0)) & "*'"
End If
Next i
'set the filter
rs.Filter = filterStr
Else
'start by enclosing the first logical string
filterStr = "("
'cycle through each word in the array of Strings
For i = LBound(str) To UBound(str)
'cycle through each column name in the recordset
For k = 0 To rs.Fields.Count - 1
'if not the final column add an "OR" at the end of the filter
If ((k < rs.Fields.Count - 2) Or (k = rs.Fields.Count - 2)) Then
filterStr = filterStr & " " & rs.Fields(k).Name & " like '" & Trim(str(i)) & "*' OR "
'if the final column AND string is not the last element add "AND (" to the end of the string to start the next
'portion of logic in the string
ElseIf ((i < UBound(str) And k = rs.Fields.Count - 1)) Then
filterStr = filterStr & " " & rs.Fields(k).Name & " like '" & Trim(str(i)) & "*') AND ("
'if last column and last string in the array, cap the filter string
Else
filterStr = filterStr & " " & rs.Fields(k).Name & " like '" & Trim(str(i)) & "*')"
End If
Next k
'add filter
rs.Filter = filterStr
Next i
End If
'set recordset and refresh the listbox
Set List.Recordset = rs.OpenRecordset
List.Requery
'housekeeping
rs.Close
Set rs = Nothing
End Function
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.
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
I have built a report within MS Access which includes a short textbox that contains web addresses. The textbox has the "CanGrow" option set to "Yes".
Because there is limited horizontal space on the report for this field, and web addresses can be very long, rather than just having the web address spill over where ever the text length forces it to such as:
http://stackoverflow.com/que
stions/ask
I am wondering if there is a way to force the text string to word wrap at the last appropriate character, in this case the "/" character. The result would be something that looks more readable such as:
http://stackoverflow.com/
questions/ask
Can this be done? Any suggestions on how to approach this task?
The following recursive function will insert a carriage-return/line-feed based on user-defined characters and a max line length. This will work best with a fixed-width font, but with some experimentation should also be acceptable for a variable width font:
Function PrettyBreak(Txt As String, MaxCharsPerLine As Long, _
Optional BreakAfterChars As String = ":=-+&?./ ") As String
Dim t As String, i As Integer, Pos As Integer
If Len(Txt) > MaxCharsPerLine Then
t = Left(Txt, MaxCharsPerLine)
For i = MaxCharsPerLine To 1 Step -1
If InStr(BreakAfterChars, Mid(t, i, 1)) <> 0 Then
Pos = i
Exit For
End If
Next i
If Pos = 0 Then
PrettyBreak = t & vbCrLf & _
PrettyBreak(Mid(Txt, MaxCharsPerLine + 1), _
MaxCharsPerLine, BreakAfterChars)
Else
PrettyBreak = Left(t, Pos) & vbCrLf & _
PrettyBreak(Mid(Txt, Pos + 1), _
MaxCharsPerLine, BreakAfterChars)
End If
Else
PrettyBreak = Txt
End If
End Function
In use:
?prettybreak("http://stackoverflow.com/questions/5583986/ms-access-report-line-break-at-character", 30)
http://stackoverflow.com/
questions/5583986/ms-access-
report-line-break-at-character