How can I create in VBA a String Const as HIGHVALUE? In Date it is e.g. 31.12.9999.
Const HIGHVALUE As String = "zzz"
Dim test As String
test = "zzzz"
If test <= HIGHVALUE Then
Debug.Print "equal or lower"
Else
Debug.Print "higher"
End If
test is higher than HIGHVALUE => so HIGHVALUE is not the highest possible string => it prints higher.
Set the length to above the maximum length you expect to test for, for example:
Const HIGHVALUE As String = "zzzzzzzz"
This is my solution to convert a String to numeric ASC, so that I could compare Strings then - anyway if there are special chars within or not:
Private Sub testGetASCValueOfString()
Debug.Print GetASCValueOfString("&$%§()[]}")
End Sub
Private Function GetASCValueOfString(test As String) As Variant
Dim i As Long, j As Long
GetASCValueOfString = 0
j = 1
For i = Len(test) To 1 Step -1
GetASCValueOfString = GetASCValueOfString + Asc(Mid$(test, i, 1)) * (j * 256)
j = j + 1
Next i
End Function
=> The advantage is, that now I don't need to compare Strings or need a String HIGHVALUE, because all is numeric now.
Related
I have a Database with many columns, one of them containing Names.
My vb.net software acts as telegram server and waits for the user to send its full name.
The database could have its name spelled differently, for example "Marco Dell'Orso" could be spelled "Marco Dellorso" or "Marco Dell Orso" od "Dell Orso Marco" or whatever. The user could also misspell his name and invert two letters.. for esample "MaCRo Dell'Orso"
I would need a way to return the 5 rows that are the most similar to the words used in the query. What would be the best way? I was thinking of splitting the name on whitechars and then use LIKE in the query with the single words, but that does not work with mistyped words.
EDIT:
My current plan is to that if the database contains more than one or less then one rows with the exact name, then split the input into the single words and return all strings that contain ANY of the input words. this should reduce the rows to analyze from 42000 to a few hundred. Once I have these few hundred lines, i could run a Levenshtein function on the rows and return the 5 most matching..
Is this a good idea?
Solved it this way by combining my custom function with a premade Levenshtein function from this link: How to calculate distance similarity measure of given 2 strings? . I assign a score for each single word that appears in the other wordcomplex. then I add a score based on the Levenshtein comparison of each word to another. works great:
Public Class Form1
Private Sub TextBox1_KeyUp(sender As Object, e As KeyEventArgs) Handles TextBox1.KeyUp
calc()
End Sub
Private Sub TextBox2_KeyUp(sender As Object, e As KeyEventArgs) Handles TextBox2.KeyUp
calc()
End Sub
Sub calc()
Label1.Text = compare(TextBox1.Text, TextBox2.Text)
End Sub
Public Function compare(source As String, target As String) As Integer
Dim score As Double
Dim sourcewords As String() = source.Split(New Char() {" "c, "'"c, "`"c, "´"c})
Dim targetwords As String() = target.Split(New Char() {" "c, "'"c, "`"c, "´"c})
For Each s In sourcewords
If target.Contains(s) Then score = score + 1
For Each t In targetwords
score = score + 1 / (DamerauLevenshteinDistance(s, t, 100) + 1)
Next
Next
For Each s In targetwords
If source.Contains(s) Then score = score + 1
For Each t In sourcewords
score = score + 1 / (DamerauLevenshteinDistance(s, t, 100) + 1)
Next
Next
Return score
End Function
''' <summary>
''' Computes the Damerau-Levenshtein Distance between two strings, represented as arrays of
''' integers, where each integer represents the code point of a character in the source string.
''' Includes an optional threshhold which can be used to indicate the maximum allowable distance.
''' </summary>
''' <param name="source">An array of the code points of the first string</param>
''' <param name="target">An array of the code points of the second string</param>
''' <param name="threshold">Maximum allowable distance</param>
''' <returns>Int.MaxValue if threshhold exceeded; otherwise the Damerau-Leveshteim distance between the strings</returns>
Public Shared Function DamerauLevenshteinDistance(source As String, target As String, threshold As Integer) As Integer
Dim length1 As Integer = source.Length
Dim length2 As Integer = target.Length
' Return trivial case - difference in string lengths exceeds threshhold
If Math.Abs(length1 - length2) > threshold Then
Return Integer.MaxValue
End If
' Ensure arrays [i] / length1 use shorter length
If length1 > length2 Then
Swap(target, source)
Swap(length1, length2)
End If
Dim maxi As Integer = length1
Dim maxj As Integer = length2
Dim dCurrent As Integer() = New Integer(maxi) {}
Dim dMinus1 As Integer() = New Integer(maxi) {}
Dim dMinus2 As Integer() = New Integer(maxi) {}
Dim dSwap As Integer()
For i As Integer = 0 To maxi
dCurrent(i) = i
Next
Dim jm1 As Integer = 0, im1 As Integer = 0, im2 As Integer = -1
For j As Integer = 1 To maxj
' Rotate
dSwap = dMinus2
dMinus2 = dMinus1
dMinus1 = dCurrent
dCurrent = dSwap
' Initialize
Dim minDistance As Integer = Integer.MaxValue
dCurrent(0) = j
im1 = 0
im2 = -1
For i As Integer = 1 To maxi
Dim cost As Integer = If(source(im1) = target(jm1), 0, 1)
Dim del As Integer = dCurrent(im1) + 1
Dim ins As Integer = dMinus1(i) + 1
Dim [sub] As Integer = dMinus1(im1) + cost
'Fastest execution for min value of 3 integers
Dim min As Integer = If((del > ins), (If(ins > [sub], [sub], ins)), (If(del > [sub], [sub], del)))
If i > 1 AndAlso j > 1 AndAlso source(im2) = target(jm1) AndAlso source(im1) = target(j - 2) Then
min = Math.Min(min, dMinus2(im2) + cost)
End If
dCurrent(i) = min
If min < minDistance Then
minDistance = min
End If
im1 += 1
im2 += 1
Next
jm1 += 1
If minDistance > threshold Then
Return Integer.MaxValue - 1
End If
Next
Dim result As Integer = dCurrent(maxi)
Return If((result > threshold), Integer.MaxValue, result)
End Function
Private Shared Sub Swap(Of T)(ByRef arg1 As T, ByRef arg2 As T)
Dim temp As T = arg1
arg1 = arg2
arg2 = temp
End Sub
End Class
One way is to use the build-in soundex function of MySQL.
SELECT SOUNDEX(name) FROM table;
Or, the better way, there are a few MySQL-functions on the web implementing DoubleMetaphone. I think this is what you are searching:
GitHub
I'm using Join(Lookupset) to find unique group values which returns a sequence number. This is my function:
Join(LookupSet(Fields!itemId.Value & Fields!UseByDate.Value & Fields!rackId.Value
, Fields!itemId.Value & Fields!UseByDate.Value & Fields!rackId.Value
, Fields!CustomerSeqNo.Value
, "PickingList"), ",")
The problem is on some items there are multiple transactions. I want to remove the duplicates.
I found a blog http://blogs.msdn.com/b/bobmeyers/archive/2012/06/18/creating-short-lists-using-the-lookupset-function.aspx but could not get SSRS Report Builder to reference Linq assembly. My issue is
How can I just show the unique values?
You don't need Linq, but you do still need custom code (in BIDS go to Report -> Report Properties -> Code)
You can put a RemoveDuplicates function in here, something like this:
Public Shared Function RemoveDuplicates(m_Array As Object()) As String()
System.Array.Sort(m_Array)
Dim k As Integer = 0
For i As Integer = 0 To m_Array.Length - 1
If i > 0 AndAlso m_Array(i).Equals(m_Array(i - 1)) Then
Continue For
End If
m_Array(k) = m_Array(i)
k += 1
Next
Dim unique As [String]() = New [String](k - 1) {}
System.Array.Copy(m_Array, 0, unique, 0, k)
Return unique
End Function
To use it in your Join:
Join(Code.RemoveDuplicates(LookupSet(...)),",")
I agree with #user3697615 that Report Code is best. However, I prefer to build it straight into a string:
public shared function JoinDistinct(
dups as object(),
delimiter as string
) as string
dim result as string = ""
system.array.sort(dups)
for i as integer = 0 to dups.length - 1
if i <> 0 then result += delimiter
if i = 0 orElse dups(i) <> dups(i-1) then result += dups(i)
next i
return result
end function
This way, we eliminate one nested function on the call:
=Code.JoinDistinct(LookupSet(...), ",")
If you're like me, you also want the elements in order based on frequency (descending order).
I created the following VisualBasic code to do so
Public Shared Function RemoveDuplicates(dataset As Object()) As String()
Dim unique As New System.Collections.Generic.List(Of String)
Dim frequency As New System.Collections.Generic.List(Of Integer)
For i As Integer = 0 To dataset.Length - 1
Dim index As Integer = -1
For j As Integer = 0 To unique.Count - 1
If dataset(i).Equals(unique(j)) Then
index = j
Exit For
End If
Next
If index < 0 Then
unique.Add(dataset(i))
frequency.Add(1)
Else
frequency(index) += 1
End If
Next
Dim uniqueArray As [String]() = unique.ToArray()
Array.Sort(frequency.ToArray(), uniqueArray)
Array.Reverse(uniqueArray)
return uniqueArray
End Function
This is based off others' answers where the SSRS expression is the following
Join(Code.RemoveDuplicates(LookupSet(...)),",")
Note: I learned VisualBasic in about an hour to solve this problem, so my algorithm probably isn't the most efficient.
I liked pwilcox's idea, so I wrote this one which filters out null and blank values.
Public Function JoinDistinct(arr As Object(), delimiter As String) As String
System.Array.Sort(arr)
Dim result As String = String.Empty
Dim lastvalue As String = String.Empty
For i As Integer = 0 To arr.Length - 1
If Not arr(i) Is Nothing And arr(i) <> lastvalue And arr(i) <> String.Empty Then
If result = String.Empty Then
result = arr(i)
Else
result = result + delimiter + arr(i)
End If
End If
lastvalue = arr(i)
Next
Return result
End Function
Usage:
=Code.JoinDistinct(LookupSet(...), ",")
In one Short Text column of a table such data was stored "any_text_N" where N is some number specific for each row.
I need to replace N by N+1.
Could any one provide query to do it?
Assuming (1) the number is always the rightmost characters, and (2) there is an underscore preceding the number, you can create a Function to parse the number and return the incremented value (see below).
Then to test it, create a query like follows (MAKE SURE YOU TEST FIRST!!!):
SELECT Table2.MyText, resetnbr([MyText]) AS NewVal
FROM Table2
WHERE (((Table2.MyText) Is Not Null));
Then to update your data:
UPDATE Table2 SET Table2.MyText= resetnbr([MyText])
WHERE (((Table2.MyText) Is Not Null));
Public Function ResetNbr(strIn As String) As String
'Assumes: (1) Number in rightmost position of string; (2) underscore preceeds number
Dim iLen As Integer
Dim i As Integer
Dim sNbr As String
If strIn = "" Then
ResetNbr = strIn
Exit Function
End If
iLen = Len(strIn)
For i = iLen To 1 Step -1
If Mid(strIn, i, 1) = "_" Then
Exit For
End If
Next i
If i > 1 Then
sNbr = Mid(strIn, i + 1, 99)
sNbr = sNbr + 1
ResetNbr = left(strIn, i) & sNbr
Else
' No underscore found!
ResetNbr = strIn
End If
End Function
I have been trying to figure this error out for the past few days with no luck. I am hoping one of you would be able to help. I am getting "value used in formula of wrong data type.
Quick explanation:
convert functions like this one to its corresponding text (20054/18393)*100.0
the 5 digit numbers are Field IDs that refer to questions.
ID Question
20054 How many days of year do you work
18393 How many days of vacation do you get a year
The result I am trying to get to is (How many days of year do you work / How many days of vacation do you get a year) *100.0
It could be easily done manually if it was just a hand full. I have over 2600 formulas that need to be converted.
I created this function below which is resulting in the error mentioned in the title. Any assistance would be greatly appreciated
Here is my function
Function Test(sInput As String) As String
Dim i As Long
Dim num As String
Dim Text, a, str, shortname As String
For i = 1 To Len(sInput)
a = Mid(sInput, i, 1)
If IsNumeric(a) Then
num = num & a
Text = ""
Else
If a = "." Then
num = num & a
Else
'search for num value in second sheet short name
shortname = WorksheetFunction.VLookup(WorksheetFunction.Int(num), Worksheets("questionlist").Range("A3:F2537"), 5, False)
num = ""
End If
Text = shortname & a
shortname = ""
End If
str = str & Text
Next
Test = str
End Function
The error is raised because you are passing blank value to INT Function in the line
WorksheetFunction.VLookup(WorksheetFunction.Int(num), Worksheets("questionlist").Range("A3:F2537"), 5, False)
To reproduce the error Type =INT("") in any cell
To fix this handle blank values
Updated Answer:
Function Formula2Text(ByRef myCell As Range) As String
Dim QuestionId As Integer
Dim strInput As String
'Get Formula instead of values
strInput = myCell.FormulaR1C1
'Use Regex to Catch all ID's
Set Regex = CreateObject("VBScript.RegExp")
Set rnglookup = Worksheets("questionlist").Range("A3:F2537")
Regex.Global = True
Regex.Pattern = "\d+"
For Each Match In Regex.Execute(strInput)
'Skip if the ID is 100
If (Match.Value <> 100) Then QuestionId = Match.Value
'Lookup ID in the rnglookup,Make sure the Ids are sorted in asc in the questionlist sheet
Qntxt = Application.VLookup(QuestionId, rnglookup, 5, False)
If IsError(Qntxt) Then Qntxt = "Missing Lookup"
'Replace the ID with the lookup
strInput = Replace(strInput, QuestionId, Qntxt)
Next
Formula2Text = strInput
End Function
Usage:In the cell next to the formula use the function by referencing the formula
=Formula2Text(A1)
I have a loop I created to check if the values entered match an ordering, depending on the augment passed. So for example the ordering constraint must be
"SU", "M", "TU", "W", "TH", "F", "SA"
therefore if the user enters the following inputs
"SU,M,TU,SA" this is correct
however if the user enters
"SU,TH,M" this is incorrect since M should come before TH
The coding has been implemented and works fine however i don't find this was the best way of coding it, can anyone help me code it more efficiently?
Function validExDays(exDays As String)
Dim found As Boolean
found = False
If Len(exDays) >= 1 And Not IsNull(exDays) Then
Dim NumOfCommas As Integer
NumOfCommas = InstrCount(exDays, ",")
Dim days(0 To 7) As String
days(0) = ","
days(1) = "SU"
days(2) = "M"
days(3) = "TU"
days(4) = "W"
days(5) = "TH"
days(6) = "F"
days(7) = "SA"
Dim i, j, k, l, m, o, p, q As Integer
i = 1
j = 1
k = 1
l = 1
m = 1
o = 1
p = 1
q = 1
Do While i <= 7
If NumOfCommas = 0 Then
'One day input check
If i = 1 Then
Do While j <= 7
If UCase(exDays) = days(j) Then
found = True
Exit Do
End If
j = j + 1
Loop
End If
End If
'Two day input check
j = 1
If NumOfCommas = 1 Then
If found = False And i = 2 Then
Do While j <= 7
Do While k <= 7
If UCase(exDays) = days(j) + days(0) + days(k) Then
found = True
Exit Do
End If
k = k + 1
Loop
If found = False Then
j = j + 1
k = j
Else
Exit Do
End If
Loop
End If
End If
'Three day input check
So the string value entered can be "SU,M,F" or "SU,F" or any other combination but whatever items are included must be in the correct order.
The following code is a bit more compact. It uses the Split() function to break out the components, and uses a Dictionary object to hold the index values of each valid component
Option Compare Database
Option Explicit
Public Function IsValidExDays(exDays As String) As Boolean
Dim rtn As Boolean
Dim valueArray() As String, valueItem As Variant
Dim maxValue As Integer
Dim dict As Object ' Scripting.Dictionary
rtn = True
Set dict = CreateObject("Scripting.Dictionary")
dict.Add "SU", 1
dict.Add "M", 2
dict.Add "TU", 3
dict.Add "W", 4
dict.Add "TH", 5
dict.Add "F", 6
dict.Add "SA", 7
maxValue = 0
valueArray = Split(exDays, ",")
For Each valueItem In valueArray
If dict.Exists(valueItem) Then
If dict(valueItem) > maxValue Then
maxValue = dict(valueItem)
Else
rtn = False
Exit For
End If
Else
rtn = False
Exit For
End If
Next
Set dict = Nothing
IsValidExDays = rtn
End Function
Since you are in Access, why don't you make an entry form with checkboxes that will always return the parameters in the order you expect?