I am writing a Macro to validate LEI codes.
LEI Code is:
20 char string
First 18 chars alphanumeric
Last two chars numeric
Example: F50EOCWSQFAUVO9Q8Z97
Validation
Replace all alphabetical chars in string with 2 digit number to create integer
If mod of integer divided by 97 is 1 then code valid, else invalid
I have written the below:
Sub Test()
Dim LEI_String As String
LEI_String = Range("B1")
LEI_String = Replace(LEI_String, "A", "10")
LEI_String = Replace(LEI_String, "B", "11")
LEI_String = Replace(LEI_String, "C", "12")
LEI_String = Replace(LEI_String, "D", "13")
LEI_String = Replace(LEI_String, "E", "14")
LEI_String = Replace(LEI_String, "F", "15")
LEI_String = Replace(LEI_String, "G", "16")
LEI_String = Replace(LEI_String, "H", "17")
LEI_String = Replace(LEI_String, "I", "18")
LEI_String = Replace(LEI_String, "J", "19")
LEI_String = Replace(LEI_String, "K", "20")
LEI_String = Replace(LEI_String, "L", "21")
LEI_String = Replace(LEI_String, "M", "22")
LEI_String = Replace(LEI_String, "N", "23")
LEI_String = Replace(LEI_String, "O", "24")
LEI_String = Replace(LEI_String, "P", "25")
LEI_String = Replace(LEI_String, "Q", "26")
LEI_String = Replace(LEI_String, "R", "27")
LEI_String = Replace(LEI_String, "S", "28")
LEI_String = Replace(LEI_String, "T", "29")
LEI_String = Replace(LEI_String, "U", "30")
LEI_String = Replace(LEI_String, "V", "31")
LEI_String = Replace(LEI_String, "W", "32")
LEI_String = Replace(LEI_String, "X", "33")
LEI_String = Replace(LEI_String, "Y", "34")
LEI_String = Replace(LEI_String, "Z", "35")
MsgBox Len(LEI_String)
Range("B2").Value = CCur(LEI_String) Mod 97
MsgBox CCur(LEI_String) Mod 97
End Sub
And am of course getting run-time error 6 overflow errors as the integer I am working with is 35 digits long.
Is there a way of working around this?
The LEI number is too big to fit in a Decimal type. To get the modulo, you'll have to compute the modulo on each digit once converted to base 10:
Private Sub Test()
Debug.Print IsValidLEI("F50EOCWSQFAUVO9Q8Z97") ' >> True '
Debug.Print IsValidLEI("T50EOCWSQFAUVO9Q8Z97") ' >> False '
End Sub
Public Function IsValidLEI(lei As String) As Boolean
Dim i As Long, c As Long, m As Long
For i = 1 To Len(lei) ' each character '
c = AscW(Mid(lei, i, 1)) ' get the character code (see ASCII table) '
Select Case c
Case 48 To 57 ' 0-9 -> 0-9 '
m = (m * 10 + c - 48) Mod 97 ' x10 to shift 1 digit, -48 to convert to base10 '
Case 65 To 90 ' A-Z -> 10-35 '
m = (m * 100 + c - 55) Mod 97 ' x100 to shift 2 digits, -55 to convert to base10 '
Case Else
Err.Raise 5, , "Unexpected character at " & i
End Select
Next
IsValidLEI = m = 1
End Function
Sub Test()
Dim LEI_String As String
LEI_String = Range("B1")
LEI_String = Replace(LEI_String, "A", "10")
LEI_String = Replace(LEI_String, "B", "11")
LEI_String = Replace(LEI_String, "C", "12")
LEI_String = Replace(LEI_String, "D", "13")
LEI_String = Replace(LEI_String, "E", "14")
LEI_String = Replace(LEI_String, "F", "15")
LEI_String = Replace(LEI_String, "G", "16")
LEI_String = Replace(LEI_String, "H", "17")
LEI_String = Replace(LEI_String, "I", "18")
LEI_String = Replace(LEI_String, "J", "19")
LEI_String = Replace(LEI_String, "K", "20")
LEI_String = Replace(LEI_String, "L", "21")
LEI_String = Replace(LEI_String, "M", "22")
LEI_String = Replace(LEI_String, "N", "23")
LEI_String = Replace(LEI_String, "O", "24")
LEI_String = Replace(LEI_String, "P", "25")
LEI_String = Replace(LEI_String, "Q", "26")
LEI_String = Replace(LEI_String, "R", "27")
LEI_String = Replace(LEI_String, "S", "28")
LEI_String = Replace(LEI_String, "T", "29")
LEI_String = Replace(LEI_String, "U", "30")
LEI_String = Replace(LEI_String, "V", "31")
LEI_String = Replace(LEI_String, "W", "32")
LEI_String = Replace(LEI_String, "X", "33")
LEI_String = Replace(LEI_String, "Y", "34")
LEI_String = Replace(LEI_String, "Z", "35")
MsgBox Len(LEI_String)
Range("B2").Value = Round(LEI_String / 97, 0)
MsgBox Round(LEI_String / 97, 0)
End Sub
Here is a way to validate an LEI using Regex and C#
bool IsValidLEI(string lei) {
Regex leiValidationRegex = new Regex(#"[A-Z0-9]{18}\d{2}");
return leiValidationRegex.IsMatch(lei);
}
Related
I need to insert a transliteration function to a subroutine that copies the contents of a document, inserts it into a temporary document and then the transliteration function should be performed. then it will be copied from the temporary document to the main one below the source text. i dont know how to insert function in a sub. which objects/methods/properties should i use?
function:
Function f(ByVal txt As String) As String
Dim RUS As String, ENG As Variant, i As Integer, b As Boolean
ENG = Array("shh", "e'", "y'", "''", "ya", "yo", "yu", "zh","ch","sh", "a", "b", "v", "g", "d", "e", "z", "i", "j", "k", "l", "m", "n", "o", "p", "r", "s", "t", "u", "f", "x", "c", "'", "Shh", "E'", "Y'", "Ya", "Yo", "Yu", "Zh", "Ch", "Sh", "A", "B", "V", "G", "D", "E", "Z", "I", "J", "K", "L", "M", "N", "O", "P", "R", "S", "T", "U", "F", "X", "C")
RUS = "щэыъяёюжчшабвгдезийклмнопрстуфхцьЩЭЫЯЁЮЖЧШАБВГДЕЗИЙКЛМНОПРСТУФХЦ"
For i = 0 To 63
If InStr(1, txt, Mid$(RUS, i + 1, 1), vbBinaryCompare) Then b = True
temp = Mid$(RUS, i + 1, 1)
txt = Replace$(txt, IIf(b, temp, ENG(i)), IIf(b, ENG(i), temp))
Next
f = txt
End Function
subroutine:
Sub test()
Dim tempDoc As Document, doc As Document
Set doc = ActiveDocument
Set tempDoc = Documents.Add
doc.Range.Copy
tempDoc.Activate
Selection.Paste
'insert function here (i guess)
tempDoc.Range.Copy
doc.Activate
With Selection
.EndKey Unit:=wdStory
.Collapse Direction:=wdCollapseEnd
End With
Selection.TypeParagraph
Selection.Paste
tempDoc.Close 0
ActiveDocument.Range.Characters.Last.Previous.Delete
End Sub
For example:
Sub test()
Dim doc As Document: Set doc = ActiveDocument
doc.Characters.Last.Text = vbcr & f(doc.Range.Text)
End Sub
I am new to VBA and Syntax in VBA is not very friendly to me. I'm trying to validate a field which is string type. In that particular field, I want the string contains letters and comma and space only.
This is my current approach:
myArray = Array("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", " ", ",", "-", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
If Not IsInArray(erName.Text, myArray) Then
valid = False
erName.ForeColor = vbRed
End If
And the IsInArray function is like the following:
Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
Dim i
For i = LBound(arr) To UBound(arr)
If arr(i) = stringToBeFound Then
IsInArray = True
Exit Function
End If
Next i
IsInArray = False
End Function
But this is not a very efficient approach because I don't want to loop over the array for every character in the string. Is there a simple way to perform this validation? Any help is appreciated. Thank you.
RegEx solution
Function StringCheck(str)
Set objRegEx = New RegExp
With objRegEx
.IgnoreCase = True
.Global = False
.MultiLine = False
.Pattern = "[a-zA-Z, ]*" 'alphabets + comma + space
End With
Set objMatch = objRegEx.Execute(str)
If objMatch.Count = 1 Then
If Len(str)=Len(objMatch(0).Value) Then 'if len of string matches the regex find
StringCheck = True
Else
StringCheck = False
End If
Else
StringCheck = False
End If
End Function
MsgBox StringCheck("Pankaj Jaju") 'True
MsgBox StringCheck("Pankaj_Jaju") 'False
MsgBox StringCheck("Pankaj,Jaju") 'True
MsgBox StringCheck("Pankaj,Jaju 1234") 'False
You don't have to loop over every character to check whether it lies in your defined array. You just need to check whether the given character is in range of the permitted ASCII values :
ASCII value of character i >= 65 and <=90 (For upper case letters)
OR
ASCII value of character i >= 97 and <= 122 (For lower caase letters)
OR
ASCII value of character i == 44 (For comma)
OR
ASCII value of character i == 32 (For space)
You can define a check for these four conditions to avoid loop.
Public Function IsInArray(stringToBeFound As String) As Boolean
Dim i
For i = 1 to Len(stringToBeFound)
If (stringToBeFound(i) >= 65 and stringToBeFound(i) <= 90) or (stringToBeFound(i) >= 97 and stringToBeFound(i) <= 122) or
(stringToBeFound(i) = 44) or
(stringToBeFound(i) = 32) Then
IsInArray = True
Exit Function
End If
Next i
IsInArray = False
End Function
I'm currently doing a soundex system for homework. For the assignment, I need to replace certain letters with certain numbers. For the assignment, I'm using a do loop. The problem is that only one letter in the string is replaced with a number, while the rest of the letters besides the first one are deleted. For example, Robert is supposed to come out as "R163," but it instead comes out as "R300". I was wondering what I'm doing wrong. My code is:
Private Sub btnCompute_Click(sender As Object, e As EventArgs) Handles btnCompute.Click
Dim word As String = txtInput.Text
Dim first As String = txtInput.Text.Substring(0, 1)
Dim rest As String = txtInput.Text.Substring(1, word.Length - 1)
Dim test As String = ""
Dim combine As String = ""
Dim i As Integer = 0
Do
Select Case rest.Substring(i)
Case "a", "e", "i", "o", "u", "h", "y", "w"
test &= ""
Case "b", "f", "p", "v"
test &= "1"
Case "c", "g", "j", "k", "q", "s", "x", "z"
test &= "2"
Case "d", "t"
test &= "3"
Case "l"
test &= "4"
Case "m", "n"
test &= "5"
Case "r"
test &= "6"
End Select
i += 1
Loop Until i > rest.Length
combine = first & test
If combine.Length < 4 Then
Do While combine.Length < 4
combine &= "0"
Loop
ElseIf combine.Length > 4 Then
combine = combine.Substring(4)
End If
txtSound.Text = combine
End Sub
Trying to keep things as similar to your example... This should work.
Dim word As String = txtInput.Text
Dim test As String = String.Empty
Dim combine As String = String.Empty
For i As Integer = 1 To word.Length - 1
Select Case word.Substring(i, 1)
Case "a", "e", "i", "o", "u", "h", "y", "w"
test &= ""
Case "b", "f", "p", "v"
test &= "1"
Case "c", "g", "j", "k", "q", "s", "x", "z"
test &= "2"
Case "d", "t"
test &= "3"
Case "l"
test &= "4"
Case "m", "n"
test &= "5"
Case "r"
test &= "6"
End Select
Next
combine = (word.Substring(0, 1) & test).PadRight(4, "0")
txtSound.Text = combine
I need to look through all characters and check if they are numbers or text items. If they are of either kind, I need to change their font accordingly. I have managed to do this in excel vba using some built in functions. But seems rather impossible in powerpoint.
Its rather primitive but does work. However, oddly, some parts get done properly others don't. I am unable to figure it out.
I have used this code:
Sub FontChange()
Dim sld As Slide
Dim shp As Shape
Dim foundText As Variant
Dim findNumber As Variant
Dim findCharacter As Variant
Dim x As Long
Dim y As Long
'Dim i As Integer
'Dim j As Character
findNumber = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
findCharacter = Array("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then ' Not all shapes do
If shp.TextFrame.HasText Then ' the shape may contain no text
For x = LBound(findNumber) To UBound(findNumber)
Set foundText = shp.TextFrame.TextRange.Find(FindWhat:=findNumber(x))
Do While Not (foundText Is Nothing)
With foundText
.Font.Size = 18
.Font.Name = "Meta-Normal"
'.Bold = False
'.Color.RGB = RGB(255, 127, 255)
Set foundText = _
shp.TextFrame.TextRange.Find(FindWhat:="findNumber(x)", _
After:=.Start + .Length - 1)
End With
Loop
Next x
End If
End If
Next shp
Next sld
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then ' Not all shapes do
If shp.TextFrame.HasText Then ' the shape may contain no text
For y = LBound(findCharacter) To UBound(findCharacter)
Set foundText = shp.TextFrame.TextRange.Find(FindWhat:=findCharacter(y))
Do While Not (foundText Is Nothing)
With foundText
.Font.Size = 18
.Font.Name = "Neo Sans Pro Light"
'.Bold = False
'.Color.RGB = RGB(255, 127, 255)
Set foundText = _
shp.TextFrame.TextRange.Find(FindWhat:="findCharacter(y)", _
After:=.Start + .Length - 1)
End With
Loop
Next y
End If
End If
Next shp
Next sld
End Sub
This might be a more elegant approach. Two private functions to individually check the text. You could combine for an OR statement, but I left as two separate items for simplicity.
Sub FontChange()
Dim sld As Slide
Dim shp As Shape
Dim x As Long
Dim y As Long
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then ' Not all shapes do
If shp.TextFrame.HasText Then ' the shape may contain no text
If NumbersExist(shp.TextFrame.TextRange) Then
'if Number exists
End If
If LettersExist(shp.TextFrame.TextRange) Then
'What to do if text exists)
End If
Next shp
Next sld
End Sub
Private Function LettersExist(yourText As String) As Boolean
Dim FindCharacter As Variant, i As Integer
FindCharacter = Array("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
For i = 0 To 25
If InStr(1, yourText, FindCharacter(i), vbTextCompare) > 0 Then
LettersExist = True
Exit Function
End If
Next i
End Function
Private Function NumbersExist(yourText As String) As Boolean
Dim FindNumber As Variant, i As Integer
FindNumber = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
For i = 0 To 9
If InStr(1, yourText, FindNumber(i), vbTextCompare) > 0 Then
NumbersExist = True
Exit Function
End If
Next i
End Function
I have two "FOR" loops and one permutation in it (which is 3 for-each loops). The permutation creates a 3 character string and works by looping through an array of characters. This work fine for me. Here is the working part.
Dim chars() = {"0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z"}
For varXR = 25 To 35
For varEVD = 0 To 99
For Each x1 In chars
For Each x2 In chars
For Each x3 In chars
Console.Writeline(varXR & varEVD & x1 & x2 & x3)
Next
Next
Next
Next
Next
I need to create a thread for each varEVD (100 threads) and make each thread work with the permutation loops. And when these threads are complete, move on and continue with the exact same thing for the next varXR.. any example would be appreciated.
Oh, and i need every varEVD loop to have same range (0-99). Thanks!
EDIT: The application is a console application!
It's not a good idea to create 100 threads. The parallel processing is still limited by the number of core you have.
It's hard to see what you're trying to actually do here but you could remove some of the code out of the loop. If you really need to do a WriteLine, then that'll be the slowest part of your code no mather if you have threads or not.
Dim chars() = {"0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z"}
Dim combinations As New List(Of String)
For Each x1 In chars
For Each x2 In chars
For Each x3 In chars
combinations.Add(x1 & x2 & x3)
Next
Next
Next
For varXR = 25 To 35
For varEVD = 0 To 99
For Each c As String In combinations
Console.WriteLine(varXR & varEVD & c)
Next
Next
Next