IsDate function returns unexpected results - vba

How come IsDate("13.50") returns True but IsDate("12.25.2010") returns False?

I got tripped up by this little "feature" recently and wanted to raise awareness of some of the issues surrounding the IsDate function in VB and VBA.
The Simple Case
As you'd expect, IsDate returns True when passed a Date data type and False for all other data types except Strings. For Strings, IsDate returns True or False based on the contents of the string:
IsDate(CDate("1/1/1980")) --> True
IsDate(#12/31/2000#) --> True
IsDate(12/24) --> False '12/24 evaluates to a Double: 0.5'
IsDate("Foo") --> False
IsDate("12/24") --> True
IsDateTime?
IsDate should be more precisely named IsDateTime because it returns True for strings formatted as times:
IsDate("10:55 AM") --> True
IsDate("23:30") --> True 'CDate("23:30") --> 11:30:00 PM'
IsDate("1:30:59") --> True 'CDate("1:30:59") --> 1:30:59 AM'
IsDate("13:55 AM") --> True 'CDate("13:55 AM")--> 1:55:00 PM'
IsDate("13:55 PM") --> True 'CDate("13:55 PM")--> 1:55:00 PM'
Note from the last two examples above that IsDate is not a perfect validator of times.
The Gotcha!
Not only does IsDate accept times, it accepts times in many formats. One of which uses a period (.) as a separator. This leads to some confusion, because the period can be used as a time separator but not a date separator:
IsDate("13.50") --> True 'CDate("13.50") --> 1:50:00 PM'
IsDate("12.25") --> True 'CDate("12.25") --> 12:25:00 PM'
IsDate("12.25.10") --> True 'CDate("12.25.10") --> 12:25:10 PM'
IsDate("12.25.2010")--> False '2010 > 59 (number of seconds in a minute - 1)'
IsDate("24.12") --> False '24 > 23 (number of hours in a day - 1)'
IsDate("0.12") --> True 'CDate("0.12") --> 12:12:00 AM
This can be a problem if you are parsing a string and operating on it based on its apparent type. For example:
Function Bar(Var As Variant)
If IsDate(Var) Then
Bar = "This is a date"
ElseIf IsNumeric(Var) Then
Bar = "This is numeric"
Else
Bar = "This is something else"
End If
End Function
?Bar("12.75") --> This is numeric
?Bar("12.50") --> This is a date
The Workarounds
If you are testing a variant for its underlying data type, you should use TypeName(Var) = "Date" rather than IsDate(Var):
TypeName(#12/25/2010#) --> Date
TypeName("12/25/2010") --> String
Function Bar(Var As Variant)
Select Case TypeName(Var)
Case "Date"
Bar = "This is a date type"
Case "Long", "Double", "Single", "Integer", "Currency", "Decimal", "Byte"
Bar = "This is a numeric type"
Case "String"
Bar = "This is a string type"
Case "Boolean"
Bar = "This is a boolean type"
Case Else
Bar = "This is some other type"
End Select
End Function
?Bar("12.25") --> This is a string type
?Bar(#12/25#) --> This is a date type
?Bar(12.25) --> This is a numeric type
If, however, you are dealing with strings that may be dates or numbers (eg, parsing a text file), you should check if it's a number before checking to see if it's a date:
Function Bar(Var As Variant)
If IsNumeric(Var) Then
Bar = "This is numeric"
ElseIf IsDate(Var) Then
Bar = "This is a date"
Else
Bar = "This is something else"
End If
End Function
?Bar("12.75") --> This is numeric
?Bar("12.50") --> This is numeric
?Bar("12:50") --> This is a date
Even if all you care about is whether it is a date, you should probably make sure it's not a number:
Function Bar(Var As Variant)
If IsDate(Var) And Not IsNumeric(Var) Then
Bar = "This is a date"
Else
Bar = "This is something else"
End If
End Function
?Bar("12:50") --> This is a date
?Bar("12.50") --> This is something else
Peculiarities of CDate
As #Deanna pointed out in the comments below, the behavior of CDate() is unreliable as well. Its results vary based on whether it is passed a string or a number:
?CDate(0.5) --> 12:00:00 PM
?CDate("0.5") --> 12:05:00 AM
Trailing and leading zeroes are significant if a number is passed as a string:
?CDate(".5") --> 12:00:00 PM
?CDate("0.5") --> 12:05:00 AM
?CDate("0.50") --> 12:50:00 AM
?CDate("0.500") --> 12:00:00 PM
The behavior also changes as the decimal part of a string approaches the 60-minute mark:
?CDate("0.59") --> 12:59:00 AM
?CDate("0.60") --> 2:24:00 PM
The bottom line is that if you need to convert strings to date/time you need to be aware of what format you expect them to be in and then re-format them appropriately before relying on CDate() to convert them.

Late to the game here (mwolfe02 answered this a year ago!) but the issue is still real, there are alternative approaches worth investigating, and StackOverflow is the place to find them: so here's my own answer...
I got tripped up by VBA.IsDate() on this very issue a few years ago, and coded up an extended function to cover cases that VBA.IsDate() handles badly. The worst one is that floats and integers return FALSE from IsDate, even though date serials are frequently passed as Doubles (for DateTime) and Long Integers (for dates).
A point to note: your implementation might not require the ability to check array variants. If not, feel free to strip out the code in the indented block that follows Else ' Comment this out if you don't need to check array variants. However, you should be aware that some third-party systems (including realtime market data clients) return their data in arrays, even single data points.
More information is in the code comments.
Here's the Code:
Public Function IsDateEx(TestDate As Variant, Optional LimitPastDays As Long = 7305, Optional LimitFutureDays As Long = 7305, Optional FirstColumnOnly As Boolean = False) As Boolean
'Attribute IsDateEx.VB_Description = "Returns TRUE if TestDate is a date, and is within ± 20 years of the system date.
'Attribute IsDateEx.VB_ProcData.VB_Invoke_Func = "w\n9"
Application.Volatile False
On Error Resume Next
' Returns TRUE if TestDate is a date, and is within ± 20 years of the system date.
' This extends VBA.IsDate(), which returns FALSE for floating-point numbers and integers
' even though the VBA Serial Date is a Double. IsDateEx() returns TRUE for variants that
' can be parsed into string dates, and numeric values with equivalent date serials. All
' values must still be ±20 years from SysDate. Note: locale and language settings affect
' the validity of day- and month names; and partial date strings (eg: '01 January') will
' be parsed with the missing components filled-in with system defaults.
' Optional parameters LimitPastDays/LimitFutureDays vary the default ± 20 years boundary
' Note that an array variant is an acceptable input parameter: IsDateEx will return TRUE
' if all the values in the array are valid dates: set FirstColumnOnly:=TRUE if you only
' need to check the leftmost column of a 2-dimensional array.
' * THIS CODE IS IN THE PUBLIC DOMAIN
' *
' * Author: Nigel Heffernan, May 2005
' * http://excellerando.blogspot.com/
' *
' *
' * *********************************
Dim i As Long
Dim j As Long
Dim k As Long
Dim jStart As Long
Dim jEnd As Long
Dim dateFirst As Date
Dim dateLast As Date
Dim varDate As Variant
dateFirst = VBA.Date - LimitPastDays
dateLast = VBA.Date + LimitFutureDays
IsDateEx = False
If TypeOf TestDate Is Excel.Range Then
TestDate = TestDate.Value2
End If
If VarType(TestDate) < vbArray Then
If IsDate(TestDate) Or IsNumeric(TestDate) Then
If (dateLast > TestDate) And (TestDate > dateFirst) Then
IsDateEx = True
End If
End If
Else ' Comment this out if you don't need to check array variants
k = ArrayDimensions(TestDate)
Select Case k
Case 1
IsDateEx = True
For i = LBound(TestDate) To UBound(TestDate)
If IsDate(TestDate(i)) Or IsNumeric(TestDate(i)) Then
If Not ((dateLast > CVDate(TestDate(i))) And (CVDate(TestDate(i)) > dateFirst)) Then
IsDateEx = False
Exit For
End If
Else
IsDateEx = False
Exit For
End If
Next i
Case 2
IsDateEx = True
jStart = LBound(TestDate, 2)
If FirstColumnOnly Then
jEnd = LBound(TestDate, 2)
Else
jEnd = UBound(TestDate, 2)
End If
For i = LBound(TestDate, 1) To UBound(TestDate, 1)
For j = jStart To jEnd
If IsDate(TestDate(i, j)) Or IsNumeric(TestDate(i, j)) Then
If Not ((dateLast > CVDate(TestDate(i, j))) And (CVDate(TestDate(i, j)) > dateFirst)) Then
IsDateEx = False
Exit For
End If
Else
IsDateEx = False
Exit For
End If
Next j
Next i
Case Is > 2
' Warning: For... Each enumerations are SLOW
For Each varDate In TestDate
If IsDate(varDate) Or IsNumeric(varDate) Then
If Not ((dateLast > CVDate(varDate)) And (CVDate(varDate) > dateFirst)) Then
IsDateEx = False
Exit For
End If
Else
IsDateEx = False
Exit For
End If
Next varDate
End Select
End If
End Function
A Tip for people still using Excel 2003:
If you (or your users) are going to call IsDateEx() from a worksheet, put these two lines in, immediately below the function header, using a text editor in an exported .bas file and reimporting the file, because VB Attributes are useful, but they are not accessible to the code editor in Excel's VBA IDE:
Attribute IsDateEx.VB_Description = "Returns TRUE if TestDate is a date, and is within ± 20 years of the system date.\r\nChange the defaulte default ± 20 years boundaries by setting values for LimitPastDays and LimitFutureDays\r\nIf you are checking an array of dates, ALL the values will be tested: set FirstColumnOnly TRUE to check the leftmost column only."
That's all one line: watch out for line-breaks inserted by the browser! ...And this line, which puts isDateEX into the function Wizard in the 'Information' category, alongside ISNUMBER(), ISERR(), ISTEXT() and so on:
Attribute IsDateEx.VB_ProcData.VB_Invoke_Func = "w\n9"
Use "w\n2" if you prefer to see it under the Date & Time functions: beats hell outta losing it in the morass of 'Used Defined' functions from your own code, and all those third-party add-ins developed by people who don't do quite enough to help occasional users.
I have no idea whether this still works in Office 2010.
Also, you might need the source for ArrayDimensions:
This API declaration is required in the module header:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
…And here's the function itself:
Private Function ArrayDimensions(arr As Variant) As Integer
'-----------------------------------------------------------------
' will return:
' -1 if not an array
' 0 if an un-dimmed array
' 1 or more indicating the number of dimensions of a dimmed array
'-----------------------------------------------------------------
' Retrieved from Chris Rae's VBA Code Archive - http://chrisrae.com/vba
' Code written by Chris Rae, 25/5/00
' Originally published by R. B. Smissaert.
' Additional credits to Bob Phillips, Rick Rothstein, and Thomas Eyde on VB2TheMax
Dim ptr As Long
Dim vType As Integer
Const VT_BYREF = &H4000&
'get the real VarType of the argument
'this is similar to VarType(), but returns also the VT_BYREF bit
CopyMemory vType, arr, 2
'exit if not an array
If (vType And vbArray) = 0 Then
ArrayDimensions = -1
Exit Function
End If
'get the address of the SAFEARRAY descriptor
'this is stored in the second half of the
'Variant parameter that has received the array
CopyMemory ptr, ByVal VarPtr(arr) + 8, 4
'see whether the routine was passed a Variant
'that contains an array, rather than directly an array
'in the former case ptr already points to the SA structure.
'Thanks to Monte Hansen for this fix
If (vType And VT_BYREF) Then
' ptr is a pointer to a pointer
CopyMemory ptr, ByVal ptr, 4
End If
'get the address of the SAFEARRAY structure
'this is stored in the descriptor
'get the first word of the SAFEARRAY structure
'which holds the number of dimensions
'...but first check that saAddr is non-zero, otherwise
'this routine bombs when the array is uninitialized
If ptr Then
CopyMemory ArrayDimensions, ByVal ptr, 2
End If
End Function
Please keep the acknowledgements in your source code: as you progress in your career as a developer, you will come to appreciate your own contributions being acknowledged.
Also: I would advise you to keep that declaration private. If you must make it a public Sub in another module, insert the Option Private Module statement in the module header. You really don't want your users calling any function with CopyMemoryoperations and pointer arithmetic.

Related

VBA len function not passing length

I am trying to grab a cell check if it has decimal places and remove them then place a specific format in a cell depending on how many characters there are in the number, the len function returns null, and the instr function works but when passed to a variable returns null. Thank you to anyone who can help. At the end of the first if function I print the results of the 3 variables not working to the immediate window to verify, with the Debug.Print command please go to view menu and activate immediate window to watch.
Function cnvtDta()
ActiveSheet.Select
Data1 = Range("data").Value
Dim rslt As String
rslt = Data1
Set myrng = Range("data")
Dim wot, sowot
'Find decimal place in cell
dot = myrng.Find(".", myrng)
If dot = True Then
'if decimal place strip remainders and decimal point
Dim pos, res
pos = InStr(1, rslt, ".")
res = Left(rslt, pos)
sowot = Len(res)
End If
Debug.Print res
Debug.Print sowot
Debug.Print pos
'Return specific formats to cell
'thank you kindly to anyone who can spare the time to genuinely help
End Function
So basically there's a couple of parts to your question.
Check if value has decimals. Here's one way to do it (based on values, not on strings)
Function DoesCellContainDecimals(inputRange As Range) As Boolean
Dim tolerance As Double
tolerance = 0.0001
If Not IsNumeric(inputRange.Value2) Then
'invalid argument
DoesCellContainDecimals = False
Exit Function
End If
If (Abs(Fix(inputRange.Value2) - inputRange.Value2) < tolerance) Then
'value does not have meaningful decimals
DoesCellContainDecimals = False
Else
'value has meaningful decimals
DoesCellContainDecimals = True
End If
End Function
Get the integer part of a number. There are two functions. Similar but different behavior with negative numbers (make sure if the value is a number first):
Int(6.5) '6
Fix(6.5) '6
Int(-6.5) '-7
Fix(-6.5) '-6
Format a number. Either turn it to string or set Range.NumberFormat property:
Format(6500000,"# ### ###") '6 500 000
Range("A1").NumberFormat = "# ### ##0" 'same effect as above but only when displaying in that cell.

VBA - How to check if a String is a valid hex color code?

To prevent errors, I need to check if a String retrieved from a custom input box is not a valid hex color code. So far I found various solutions for other languages, but none for VBA.
Working on the following code, giving a not hex value input will cause a run time error. That's critical to my project, since I am working on a protected sheet.
Public Function HexWindow(MyCell As String, Description As String, Caption As String)
Dim myValue As Variant
Dim priorValue As Variant
priorValue = Range(MyCell).Value
myValue = InputBox(Description, Caption, Range(MyCell).Value)
Range(MyCell).Value = myValue
If myValue = Empty Then
Range(MyCell).Value = priorValue
End If
tHex = Mid(Range(MyCell).Text, 6, 2) & Mid(Range(MyCell).Text, 4, 2) & Mid(Range(MyCell).Text, 2, 2)
Range(MyCell).Interior.Color = WorksheetFunction.Hex2Dec(tHex)
End Function
How can I set a condition that recognizes a value not being in the format of "#" & 6 characters from 0-9 and A-F in any case?
Couple ways to do this. The easiest way is with a regular expression:
'Requires reference to Microsoft VBScript Regular Expressions x.x
Private Function IsHex(inValue As String) As Boolean
With New RegExp
.Pattern = "^#[0-9A-F]{1,6}$"
.IgnoreCase = True 'Optional depending on your requirement
IsHex = .Test(inValue)
End With
End Function
If for some reason that doesn't appeal to you, you could also take advantage of VBA's permissive casting of hex strings to numbers:
Private Function IsHex(ByVal inValue As String) As Boolean
If Left$(inValue, 1) <> "#" Then Exit Function
inValue = Replace$(inValue, "#", "&H")
On Error Resume Next
Dim hexValue As Long
hexValue = CLng(inValue) 'Type mismatch if not a number.
If Err.Number = 0 And hexValue < 16 ^ 6 Then
IsHex = True
End If
End Function
I would use regular expressions for this. First you must go to Tools-->Referencesin the VBA editor (alt-f11) and make sure this library is checked
Microsoft VBScript Regular Expressions 5.5
Then you could modify this sample code to meet your needs
Sub RegEx_Tester()
Set objRegExp_1 = CreateObject("vbscript.regexp")
objRegExp_1.Global = True
objRegExp_1.IgnoreCase = True
objRegExp_1.Pattern = "#[a-z0-9]{6}"
strToSearch = "#AAFFDD"
Set regExp_Matches = objRegExp_1.Execute(strToSearch)
If regExp_Matches.Count = 1 Then
MsgBox ("This string is a valid hex code.")
End If
End Sub
The main feature of this code is this
objRegExp_1.Pattern = "#[a-z,A-Z,0-9]{6}"
It says that you will accept a string that has a # followed by any 6 characters that are a combination of upper case or lower case strings or numbers 0-9. strToSearch is just the string you are testing to see if it is a valid color hex string. I believe this should help you.
I should credit this site. You may want to check it out if you want a crash course on regular expressions. They're great once you learn how to use them.

Date Validation not working correctly

I am trying to validate a date that is entered into a textbox on a user form. When I enter for example 23/7/15 the code works fine and gives me a value as the date entered is valid, when I enter 32/7/2015 I get a message that I program telling the user that they have entered a wrong date but if I enter 32/7/15 it sets the date in the code to some date in 1932 and as this is a valid date it does not throw the error. Below is the code that I am using. Is there anyway to validate 32/7/15?
Private Function errorCheckingDate(box1, message) As Boolean '<============= Returns a True or a False
If Not IsDate(box1) Then '<============================================= Checks to see if entered value is date or not
MsgBox message, vbExclamation, "Invalid Selection" '<=============== Displays a messgae box if not date
box1.SetFocus '<==================================================== Puts cursor back to the offending box
errorCheckingDate = True '<========================================= Sets function to True
End If
End Function
box1 is just the value of the textbox once it has been converted to a date. Below is the conversion
secondSelectedStr = Format(DateTextBox.value, "dd-mm-yy") '<===== Convert to correct format
Any help would be great.
In addition to the ordering issue, VBA will also try to adapt invalid date ranges to a proper date. For example, this has always been a neat technique to get the X day of the year:
d = DateSerial(2015, 1, X)
X can be really any number here (up to the limits of the data type, of course). If X is 500, it will produce the date 2016-5-14. So the mm/dd vs dd/mm vs yy/mm/dd issue plus the fact that VBA accepts numbers outside valid ranges are both troublesome.
Without range-checking each date component (where you have to consider leap years and whatnot), I think the best solution is to just have VBA create your date and then test it to ensure it's what you're expecting. For example:
' Get the date components (assuming d/m/yy)...
Dim a As Variant
a = Split(strDate, "/")
' Need 3 components...
If UBound(a) <> 2 Then MsgBox "Invalid date": Exit Sub
' Create the date. This will hardly ever fail.
' VBA will create some kind of date using whatever numbers you throw at it.
Dim d As Date
d = DateSerial(a(2), a(1), a(0))
' Make sure the date VBA created matches what we expected...
If Day(d) <> CInt(a(0)) Then MsgBox "Invalid day": Exit Sub
If Month(d) <> CInt(a(1)) Then MsgBox "Invalid month": Exit Sub
If Right$(Year(d), 2) <> a(2) Then MsgBox "Invalid year": Exit Sub
You could throw that into a subroutine (you may have noticed the Exit Sub statements) to validate the date that gets entered. The TextBox_Exit event would work well. That way, you could set Cancel = True to prevent the user from leaving the textbox with an invalid date.
Thanks for the answers guys but I need to accommodate for leap years and other things. As the isdate function works if the date is entered in the form 1/1/2015 I have just used the len() function to make sure that the date entered is of a certain length. Below is the code that I used. Thanks for you help once again. :)
Private Function errorCheckingDate(box1, message) As Boolean '<============= Returns a True or a False
If Not IsDate(box1) Or Len(box1) < 8 Or Len(box1) > 10 Then '<============================================= Checks to see if entered value is date or not
MsgBox message, vbExclamation, "Invalid Selection" '<=============== Displays a messgae box if not date
box1.SetFocus '<==================================================== Puts cursor back to the offending box
errorCheckingDate = True '<========================================= Sets function to True
End If
End Function
Maybe instead of using IsDate you could use your own custom function likened to it.
Function isValidDate(d as String) as Boolean
Dim parts as Variant
Dim months29 as variant
Dim months30 as variant
Dim months31 as variant
months29 = Array(2)
months30 = Array(4, 6, 9, 11)
months31 = Array(1, 3, 5, 7, 8, 10, 12)
parts = Split(d, "-")
if parts(2) mod 4 = 0 then
daysLeapYear = 28
else:
daysLeapYear = 29
end if
if ((IsInArray(parts(0), months29) and parts(1) <= daysLeapYear) or _
(IsInArray(parts(0), months30) and parts(1) < 31) or _
(IsInArray(parts(0), months31) and parts(1) < 32)) and _
parts(2) < 16 then
isValidDate = True
else:
isValidDate = False
end if
end function
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
This should cover most cases. Not sure how detailed you feel you need to be. IsInArray courtesy of #JimmyPena.

vb.net string contains only 4 digit numbers(or a year)

how can i check if a string only contains 4 digit numbers ( or a year )
i tried this
Dim rgx As New Regex("^/d{4}")
Dim number As String = "0000"
Console.WriteLine(rgx.IsMatch(number)) // true
number = "000a"
Console.WriteLine(rgx.IsMatch(number)) // false
number = "000"
Console.WriteLine(rgx.IsMatch(number)) //false
number = "00000"
Console.WriteLine(rgx.IsMatch(number)) // true <<< :(
this returns false when its less than 4 or at characters but not at more than 4
thanks!
I actually wouldn't use a regex for this. The expression is deceptively simple (^\d{4}$), until you realize that you also need to evaluate that numeric value to determine a valid year range... unless you want years like 0013 or 9015. You're most likely going to want the value as an integer in the end, anyway. Given that, the best validation is probably just to actually try to convert it to an integer right off the bat:
Dim numbers() As String = {"0000", "000a", "000", "00000"}
For Each number As String In numbers
Dim n As Integer
If Integer.TryParse(number, n) AndAlso number.Length = 4 Then
'It's a number. Now look at other criteria
End If
Next
Use LINQ to check if All characters IsDigit:
Dim result As Boolean = ((Not number Is Nothing) AndAlso ((number.Length = 4) AndAlso number.All(Function(c) Char.IsDigit(c))))
You should use the .NET string manipulation functions.
Firstly the requirements, the string must:
Contain exactly four characters, no more, no less;
Must consist of a numeric value
However your aim is to validate a Date:
Function isKnownGoodDate(ByVal input As String) As Boolean 'Define the function and its return value.
Try 'Try..Catch statement (error handling). Means an input with a space (for example ` ` won't cause a crash)
If (IsNumeric(input)) Then 'Checks if the input is a number
If (input.Length = 4) Then
Dim MyDate As String = "#01/01/" + input + "#"
If (IsDate(MyDate)) Then
Return True
End If
End If
End If
Catch
Return False
End Try
End Function
You may experience a warning:
Function isKnownGoodDate does not return a value on all code
paths. Are you missing a Return statement?
this can be safely ignored.

Character Comparison QWERTY Key Proximity Typo (Access VBA Equivalent)

This requires a solution & the code to migrate to Access from VB6 is below.
I have a function to compare characters that comes from VB6 and I am a novice user on VB6 and mostly work from VBA platform. I need to setup a class or a better way in MS Access to check character by character for typo mistakes without the use of UDT.
Mytypolist as an array refers to the following dataset:
QWA WESAQ ERDSW RTFDE TYGFR YUHGT UIJHY IOKJU OPLKI PLO AQWSZ SEDXZA DRFCXSE FTGVCDR GYHBVFT HUJNBGY JIKMNHU KOLMJI LPKO ZASX XZSDC CXDFV VCFGB BVGHN NBHJM MNJK
The above data is used to compare if a character was mistyped in a word.. ex. if I use A as in Auebec instead of what I mean to type Quebec, my cluster of interest is QWA; WESAQ; AQWSZ; or any other Q arrangement on a standard English Qwerty keyboard based on proximity. And this is not just for Q, but for entire set of alphabets, regardless of case, so c has its own cluster of possible typo matches etc..
In VB6 setup of UDT (user defined type):
'declare UDT type for typos
Public Type Mytypos
Rightrkey As String * 1
PossibleKey As String * 8
End Type
'declare arrays and variable for master list and typos
Public Masterlist() As String
Public Mytypolist(26) As Mytypos
Public Matchkey As Mytypos
the following function compares two words; and assign similarity by calculating currentpct score:
Public Function CompareCharacters(ByRef MasterWord As String, _
ByRef Checkword As String, ByRef CurrentPCT As Double, _
ByRef WordVal As Long) As Double
'define function variables
Dim ChrCount As Long
Dim ChrValue As Long
Dim loop1 As Long
Dim loop2 As Long
'define the letter values
If Len(MasterWord) > Len(Checkword) Then
ChrCount = Len(MasterWord) * 2
Else
ChrCount = Len(Checkword) * 2
End If
ChrValue = 1 / ChrCount
'say CURRENT PCT has a value of 10%
'check each letter for a match in current word position
For loop1 = 1 To Len(Checkword)
'check for typo errors (key proximity)
For loop2 = 0 To UBound(Mytypolist)
Matchkey = Mytypolist(loop2)
'if indexkey = letter in masterword
If Matchkey.Rightrkey = Mid(MasterWord, loop1, 1) Then
'does the letter in the checkword exist in the proximity keylist
If InStr(1, Matchkey.PossibleKey, Mid(Checkword, loop1, 1), vbTextCompare) > 0 Then
'value for letter found in proximity keylist
CurrentPCT = CurrentPCT + ChrValue
End If
Exit For
End If
Next loop2
Next loop1
CompareCharacters = CurrentPCT
End Function
IF you can post me a array/class solution that may not produce compiler issues (String UDT in VBA are a problem). Please check it out now!
It would probably best, since you have a 1 character to 8 character thing, to just have a full mapping. Something to replace this:
Public Type Mytypos
Rightrkey As String * 1
PossibleKey As String * 8
End Type
To:
PossibleKeys(255) As String * 8
That way, each character (from 0 to 255) would have the 8 character mapping. No UDT required!