After hours of work I give up as I do not see the solution anymore.
I therefore ask for your help to create following sequence:
for example given is the start code: 6D082A
The 1st position ("A") is from an array with 16 elements in this sequence:
Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F")
the 3rd to 5th position (082) has values from 000 to 999
the 2nd position ("D") has values from "A" to "Z"
the 1st position (6) has values from 1-9
So the sequence from the example code above is:
6D082A
6D082B
6D082C
..
6D082F
6D0830
6D0831
....
6D083F
6D0840
...
6D999F
6E0000
....
6Z999F
7A0000
....
9Z999F which is the absolut last code in this sequence
Whith all the loops within the counters I am lost!
At the end the user should also enter the given first code and the number of codes he wants.
My last trial was (without any start-code and any variable number of codes to create.
Sub Create_Barcodes_neu2()
Dim strErsterBC As String
Dim intRow As Integer
Dim str6Stelle As Variant
Dim intStart6 As Integer
Dim str6 As String
Dim i As Integer, ii As Integer, Index As Integer
'On Error Resume Next
Dim v As Variant
str6Stelle = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F") '16 Elemente
strErsterBC = InputBox("Enter the first Barcode.", "Barcode-Generator")
intRow = InputBox("Enter the number of barcodes to create.", "Barcode-Generator")
intStart6 = ListIndex(Mid(strErsterBC, 6, 1), str6Stelle)
str35stelle = CInt(Mid(strErsterBC, 3, 3)) 'Zahl 000-999
str2stelle = Mid(strErsterBC, 2, 1) letters A-Z
str1stelle = Left(strErsterBC, 1)
'Debug.Print str6Stelle(1); vbTab; str6Stelle(2); vbTab; str6Stelle(15); vbTab; str6Stelle(16)
For Z = 0 To 32
ausgabe6 = i + intStart6
i = i + 1
ausgabe35 = str35stelle
ausgabe2 = i3
ausgabe1 = i4
If i = 16 Then
i = 0
i2 = i2 + 1
ausgabe35 = i2 + str35stelle
If i2 = 999 Then
ausgabe35 = 999
i2 = 0
i3 = i3 + 1
If i3 = 26 Then
ausgabe2 = 26
i3 = 1
i4 = i4 + 1
If i4 > 9 Then
MsgBox "Ende"
Exit Sub
End If
End If
End If
End If
st6 = str6Stelle(ausgabe6)
st35 = Format(ausgabe35, "000")
ausgabe2 = Chr(i3)
ausgabe1 = i4
Next Z
End Sub
Hope you can help me in my solution!
Thanks a lot!
Michael
The approach to the right algorithm is to think of a number in the following way:
Let's take a normal decimal 3-digit number. Each digit can take one element of an ordered set of symbols, 0-9.
To add 1 to this number, we exchange the rightmost symbol for the next symbol (2 becomes 3 etc.) - but if it is already the 'highest' possible symbol ("9"),
then reset it to the first possible symbol ("0"), and increase the next digit to the left by one.
So 129 becomes 130, and 199 has two carrying overflows and becomes 200. If we had 999 and tried and inc by one, we'd have a final overflow.
Now this can be easily done with any set of symbols, and they can be completely different for every digit.
In the code, you store the symbol sets for every digit. And the "number" itself is stored as an array of indexes, pointing to which symbol is
used at each position. These indexes can easily be increased.
In case of an overflow for a single digit, the function IncByOne is called recursively for the next position to the left.
This is code for a class clSymbolNumber
Option Explicit
' must be a collection of arrays of strings
Public CharacterSets As Collection
' <code> must contain integers, the same number of elements as CharacterSets
' this is the indices for each digit in the corresponding character-set
Public code As Variant
Public overflowFlag As Boolean
Public Function IncByOne(Optional position As Integer = -1) As Boolean
IncByOne = True
If position = -1 Then position = CharacterSets.Count - 1
' overflow at that position?
If code(position) = UBound(CharacterSets(position + 1)) Then
If position = 0 Then
overflowFlag = True
IncByOne = False
Exit Function
Else
' reset this digit to lowest symbol
code(position) = 0
' inc the position left to this
IncByOne = IncByOne(position - 1)
Exit Function
End If
Else
code(position) = code(position) + 1
End If
End Function
Public Sub class_initialize()
overflowFlag = False
Set CharacterSets = New Collection
End Sub
Public Function getCodeString() As String
Dim i As Integer
Dim s As String
s = ""
For i = 0 To UBound(code)
s = s & CharacterSets(i + 1)(code(i))
Next
getCodeString = s
End Function
Testing sub in a worksheet module - this outputs all possible "numbers" with the given test data.
Sub test()
Dim n As New clSymbolNumber
n.CharacterSets.Add Array("1", "2", "3")
n.CharacterSets.Add Array("a", "b")
n.CharacterSets.Add Array("A", "B", "C", "D")
n.CharacterSets.Add Array("1", "2", "3")
' start code (indexes)
n.code = Array(0, 0, 0, 0)
' output all numbers until overflow
Dim row As Long
row = 2
Me.Columns("A").ClearContents
While Not n.overflowFlag
Me.Cells(row, "A") = n.getCodeString
n.IncByOne ' return value not immediately needed here
row = row + 1
DoEvents
Wend
MsgBox "done"
End Sub
I'm not sure if this is what you're looking for:
Option Explicit
Const MAX_FIRST_DEC_NUMBER As Integer = 9
Const MAX_MIDDLE_DEC_NUMBER As Integer = 999
Const MAX_LAST_HEX_NUMBER As Long= &HF
Sub Makro()
Dim codes() As String
Dim startCode As String
Dim numOfBarcodes As Integer
startCode = "0A0000" ' Starting with the "lowest" barcode
' Maximum number of barcodes = 4,160,000 because:
'0-9' * 'A-Z' * '0-9' * '0-9' * '0-9' * 'A-F'
numOfBarcodes = CLng(10) * CLng(26) * CLng(10) * CLng(10) * CLng(10) * CLng(16)
codes = CreateBarcodes(startCode , numOfBarcodes)
Dim i As Integer
For i = 0 To numOfBarcodes - 1
Debug.Print codes(i)
Next
End Sub
' NOTE: Given "9Z999F" as start code will give you a numberOfBarcodes-sized array with
' one valid barcode. The rest of the array will be empty. There is room for improvement.
Function CreateBarcodes(ByVal start As String, ByVal numberOfBarcodes As Long) As String()
' TODO: Check if "start" is a valid barcode
' ...
' Collect barcodes:
Dim firstDecNumber As Integer
Dim char As Integer
Dim middleDecNumber As Integer
Dim lastLetter As Integer
ReDim barcodes(0 To numberOfBarcodes - 1) As String
For firstDecNumber = Left(start, 1) To MAX_FIRST_DEC_NUMBER Step 1
For char = Asc(Mid(start, 2, 1)) To Asc("Z") Step 1
For middleDecNumber = CInt(Mid(start, 3, 3)) To MAX_MIDDLE_DEC_NUMBER Step 1
For lastLetter = CInt("&H" + Mid(start, 6, 1)) To MAX_LAST_HEX_NUMBER Step 1
numberOfBarcodes = numberOfBarcodes - 1
barcodes(numberOfBarcodes) = CStr(firstDecNumber) + Chr(char) + Format(middleDecNumber, "000") + Hex(lastLetter)
If numberOfBarcodes = 0 Then
CreateBarcodes = barcodes
Exit Function
End If
Next
Next
Next
Next
CreateBarcodes = barcodes
End Function
Output:
9Z999F
9Z999E
9Z999D
...
1A0001
1A0000
0Z999F
0Z999E
...
0B0002
0B0001
0B0000
0A999F
0A999E
...
0A0011
0A0010
0A000F
0A000E
...
0A0003
0A0002
0A0001
0A0000
Related
This is my first post here. I am looking to get the largest number out of this type of text. And here is the example.
Class 1 - $250,000 - PTD equal to principal sumClass 2 - $500,000 - PTD equal to principal sumClass 3 - $500,000 - PTD equal to principal sumClass 4 - $250,000 Class 5 - $250,000 Class 6 - $250,000
Everyone of the number will have dollar sign. I have tried Scott's solution here. But no luck.
Please let me know if and how it can be done.
Thank you.
I'd go this way:
Function GetMax(s As String)
Dim val As Variant
Dim num As Double
Dim pos As Long
For Each val In Split(s, "$")
pos = 0
Do While IsNumeric(Mid(val, 1, pos + 1))
pos = pos + 1
Loop
If pos > 0 Then
num = CDbl(Mid(val, 1, pos))
If num > GetMax Then GetMax = num
End If
Next
End Function
You can just adapt the answer you linked to by first removing all the "$" signs using VBAs Replace function:
Function MaxInString(rng As String) As Double
Dim splt() As String
Dim i&
'==================NEW LINE==================='
rng = Replace(rng, "$", "")
'============================================='
splt = Split(rng)
For i = LBound(splt) To UBound(splt)
If IsNumeric(splt(i)) Then
If splt(i) > MaxInString Then
MaxInString = splt(i)
End If
End If
Next i
End Function
Based on your new requirements, here is a possible regex based solution (based on this https://stackoverflow.com/a/44339803/1011724):
Public Function max_number(s As String) As Double
Static re As VBScript_RegExp_55.RegExp
s = Replace(s, ",", "")
If re Is Nothing Then
Set re = New RegExp
re.IgnoreCase = True: re.Global = True
re.Pattern = "-?\d*\.?\d+"
End If
max_number = 0
For Each elem In re.Execute(s)
If max_number < CDbl(elem) Then
max_number = CDbl(elem)
End If
Next
End Function
Just make sure to first follow Step 1 in this answer: https://stackoverflow.com/a/22542835/1011724 to add a reference to the regex library first.
Try this code (necessary comments in code):
Option Explicit
Sub GetMaxNumber()
Dim txt As String, idx As Long, idx2 As Long, maxValue As Long, extractedNumber As Long, char As String
maxValue = 0
'set variable in a code or use cell value
'txt = Range("A1").Value
txt = "Class 1 - $250,000 - PTD equal to principal sumClass 2 - $500,000 - PTD equal to principal sumClass 3 - $500,000 - PTD equal to principal sumClass 4 - $250,000 Class 5 - $250,000 Class 6 - $250,000"
idx = InStr(1, txt, "$")
'on each loop we will look for dollar sign (you mentioned, that every number starts with it)
'and then, look for first non-comma non-numeric characted, there the number will end
'at the end we extract the number from text
Do While idx > 0
idx2 = idx + 1
char = Mid(txt, idx2, 1)
'determine the end of a number
Do While IsNumeric(char) Or char = ","
char = Mid(txt, idx2, 1)
idx2 = idx2 + 1
Loop
'extract the number, also removing comma from it
extractedNumber = Replace(Mid(txt, idx + 1, idx2 - idx - 2), ",", "")
'if extracted number is greater than current max, replace it
If maxValue < extractedNumber Then maxValue = extractedNumber
idx = InStr(idx + 1, txt, "$")
Loop
MsgBox maxValue
End Sub
I would split on the spaces, then loop through looking for dollar sign and then once found paste the string into a cell to parse out commas etc.
Note the following code uses the cell parser to strip out commas and currency signs.
Sub Test2()
Sheet1.Cells(1, 1).Value = "3,000"
Debug.Assert Sheet1.Cells(1, 1).Value = 3000
Sheet1.Cells(1, 1).Value = "$250,000"
Debug.Assert Sheet1.Cells(1, 1).Value = 250000
End Sub
Here is full listing
Sub Test()
Dim s As String
s = "Class 1 - $250,000 - PTD equal to principal sumClass 2 - $500,000 - PTD equal to principal sumClass 3 - $500,000 - PTD equal to principal sumClass 4 - $250,000 Class 5 - $250,000 Class 6 - $250,000"
Dim vSplit As Variant
vSplit = Split(s, " ")
Dim ccyMax As Currency
ccyMax = -1
Dim vSplitLoop As Variant
For Each vSplitLoop In vSplit
If Left$(vSplitLoop, 1) = "$" Then
Sheet1.Cells(1, 1).Value = vSplitLoop
Dim ccyParsed As Currency
ccyParsed = Sheet1.Cells(1, 1).Value
If ccyParsed > ccyMax Then ccyMax = ccyParsed
End If
Next
Debug.Print ccyMax
End Sub
I am trying to create a function that outputs an array.
However, I got the Function call on left-hand side must return Variant or
Object. How can I return a dynamic array from this function?
Public Function Fibonacci_Array(max As Integer) As Integer
Dim result() As Variant
ReDim result(0 To max)
'' Array indices.
Dim i1 As Integer
Dim i2 As Integer
Dim i As Integer
i1 = 0
i2 = 1
'' Array values.
Dim newVal As Long
Dim prev2 As Long
Dim prev As Long
prev2 = 0
prev = 1
'' Loop through
While prev <= max
result(i1) = prev2
result(i2) = prev
newVal = prev + prev2
''Debug.Print newVal
prev2 = prev
prev = newVal
i1 = i1 + 1
i2 = i2 + 1
Wend
'' Problem here.
Fibonacci_Array() = result
End Function
Variant is the most flexible type when it comes to passing arrays to or from functions.
Replace
Public Function Fibonacci_Array(max As Integer) As Integer
by
Public Function Fibonacci_Array(max As Integer) As Variant
Replace
Dim result() As Variant
by
Dim result As Variant
and replace
Fibonacci_Array() = result
by
Fibonacci_Array = result
That will make it compile, but you seem to need a bit of debugging, since when I then type
?Join(Fibonacci_Array(10),", ")
in the Immediate Window, I get:
0, 1, 1, 2, 3, 5, 8, , , ,
(This might be what you want if you want the Fibonacci numbers which are less than max, but then you might want to use a ReDim Preserve to pare the array down to size before returning it. If your intention was to get the first max Fibonacci numbers, the culprit is the line While prev <= max -- it isn't prev that you would want to compare to max).
On Edit I thought it would be fun to write a VBA function which returns the array of all Fibonacci numbers whose size is <= a given max. Since Fibonacci numbers grow rapidly, I decided to use Long rather than Integer, and also to use Binet's formula to calculate the size of the array (possibly +1 for safety) before filling the array, so we don't allocate an array which is much too large:
Function FibNums(max As Long) As Variant
'returns array consisting of all Fibonacci numbers <= max
'max is assumed to be >= 1
Dim i As Long, n As Long, F As Long
Dim Fibs As Variant
'come up with an upper bound on size of array:
n = 1 + Int(Log(Sqr(5) * max) / Log((1 + Sqr(5)) / 2))
ReDim Fibs(1 To n)
Fibs(1) = 1
Fibs(2) = 1
i = 2
Do While Fibs(i) <= max
F = Fibs(i - 1) + Fibs(i)
If F <= max Then
i = i + 1
Fibs(i) = F
Else
Exit Do 'loop is finished
End If
Loop
'at this stage, Fibs contains i numbers
If i < n Then ReDim Preserve Fibs(1 To i)
FibNums = Fibs
End Function
For example:
?Join(Fibnums(100000),", ")
1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, 377, 610, 987, 1597, 2584, 4181, 6765, 10946, 17711, 28657, 46368, 75025
Your return type should be the same and you don't need the parenthesis when you assign the value of the function:
Public Function Fibonacci_Array(max As Integer) As Long()
Dim result() As Long
ReDim result(0 To max)
'' Array indices.
Dim i1 As Integer
Dim i2 As Integer
Dim i As Integer
i1 = 0
i2 = 1
'' Array values.
Dim newVal As Long
Dim prev2 As Long
Dim prev As Long
prev2 = 0
prev = 1
'' Loop through
While prev <= max
result(i1) = prev2
result(i2) = prev
newVal = prev + prev2
''Debug.Print newVal
prev2 = prev
prev = newVal
i1 = i1 + 1
i2 = i2 + 1
Wend
'' Problem here.
Fibonacci_Array = result
End Function
Sub a()
Dim b() As Long
b() = Fibonacci_Array(100)
End Sub
Good people of Stackland
I'm analysing strings comprised of 5 alpha chars which in their raw format look like this;
A2) BCDBE
A3) TLDPP
A4) FGGFC
A5) BBGBB
I need a way of evaluating each character to identify patterns within the strings themselves, eg repeating letters. I want to represent these patterns as follows, where the 1st letter is always given as "A", the 2nd "B"...;
A2) BCDBE --> ABCAD
A3) TLDPP --> ABCDD
A4) FGGFC --> ABBAC
A5) BBGBB --> AABAA
Now, I have achieved this with some pretty inelegant conditional formulae but had to do this to evaluate each character individually, as follows;
1) =IF(LEFT(A2,1)>0,"A")
2) =IF(MID(A2,2,1)=LEFT(A2,1),"A","B")
3) =IF(MID(A2,3,1)=LEFT(A2,1),"A",IF(MID(A2,3,1)=MID(A2,2,1),M2,CHAR(CODE(M2)+1)))
4) =IF(MID(A2,4,1)=LEFT(A2,1),"A",IF(MID(A2,4,1)=MID(A2,2,1),M2,IF(MID(A2,4,1)=MID(A2,3,1),N2,CHAR(MAX(CODE(L2:N2)+1)))))
5) =IF(MID(A2,5,1)=LEFT(A2,1),"A",IF(MID(A2,5,1)=MID(A2,2,1),M2,IF(MID(A2,5,1)=MID(A2,3,1),N2,IF(MID(A2,5,1)=MID(A2,4,1),O2,CHAR(MAX(CODE(L2:O2)+1))))))
Translated...
1) Call the first character "A"
2) If the 2nd character is the same as the same as the 1st call it "A", otherwise cause it "B"
3) If the 3rd character is the same as the 1st call it "A", if it's the same as the 2nd call it whatever the 2nd is, if not give it the value of the next letter, ie "C"
4) If the 4th character is the same as the 1st, call it "A", if it's the sames as the 2nd call it whatever the 2nd is, if it's the same as the 3rd call it whatever the 3rd is, if not then call it the next letter in the alphabet, ie "D"
5) If the 5th character is the same as the 1st, call it "A", if it's the same as the 2nd call it whatever the 2nd is, if it's the same as the 3rd call it whatever the 3rd is called, if it's the same as the 4th call it whatever the 4th is called, if not then call it the next letter in the alphabet, ie "E"
I'm doing this over 5 cols, one formula per col, and the concatenating the 5 results into one cell to get AABAA or whatever.
I just need to know if there's a nice, clean VBA solution to this.
Any ideas?
Here is the a Function to do the letter instead of numbers:
Function findPattern(inputStr As String) As String
Dim i As Integer
Dim t As Integer
t = 1
For i = 1 To 5 Step 1
If Asc(Mid(inputStr, i, 1)) > 54 Then
inputStr = Replace(inputStr, Mid(inputStr, i, 1), t)
t = t + 1
End If
Next i
For i = 1 To 5
inputStr = Replace(inputStr, i, Chr(i + 64))
Next i
findPattern = inputStr
End Function
Put it in a module attached to the workbook, and you can call it thus:
=findPattern(A2)
Driectly from the worksheet where A2 is the cell you want tested.
Or from vba:
Sub test()
Dim str as string
str = findPattern(Range("A2").value)
debug.print str
End Sub
Edit: By your Comment I assume you have more than just the first 5 characters that you want left original. If that is the case use this:
Function findPattern(Str As String) As String
Dim inputStr As String
Dim i As Integer
Dim t As Integer
inputStr = Left(Str, 5)
t = 1
For i = 1 To 5 Step 1
If Asc(Mid(inputStr, i, 1)) > 54 Then
inputStr = Replace(inputStr, Mid(inputStr, i, 1), t)
t = t + 1
End If
Next i
For i = 1 To 5
inputStr = Replace(inputStr, i, Chr(i + 64))
Next i
'This is the return line. As is it will only return 5 characters.
'If you want the whole string with only the first five as the pattern
'Remove the single quote in the middle of the string.
findPattern = inputStr '& Mid(Str, 6, (Len(Str)))
End Function
This seems like an easy approach:
's is the input string
dim pos, c, s_new, s_old
pos = 1 : c = 49
s_new = mid(s, 1, 5) ' take only first five characters
do while pos <= 5
s_old = s_new
s_new = replace(s_new, mid(s, pos, 1), chr(c))
if s_new <> s_old then c = c + 1
loop
s_new = replace(s_new, "1", "A")
s_new = replace(s_new, "2", "B")
s_new = replace(s_new, "3", "C")
s_new = replace(s_new, "4", "D")
s_new = replace(s_new, "5", "E")
'm assuming that you don't have any numeric characters in your input.
This has a certain elegance:
Function Pattern(r As Range)
Dim c&, i&, a
Const FORMULA = "iferror(find(mid(~,{2,3,4,5},1),left(~,{1,2,3,4})),)"
a = Evaluate(Replace(FORMULA, "~", r.Address))
c = 1: Pattern = "A"
For i = 1 To 4
If a(i) = 0 Then c = c + 1: a(i) = c
Pattern = Pattern & Chr$(64 + a(i))
Next
End Function
I had this for a while (it's handy for cryptograms), so I'll post it:
Function Pattern(ByVal sInp As String) As String
' shg 2012
' Returns the pattern of a string as a string of the same length
' First unique letter and all repeats is a, second is b, …
' E.g., Pattern("mississippi") returns "abccbccbddb"
Dim iChr As Long ' character index to sInp & Pattern
Dim sChr As String ' character in sInp
Dim iPos As Long ' position of first appearance of sChr in sInp
sInp = LCase(Trim(sInp))
If Len(sInp) Then
sChr = Chr(64)
Pattern = sInp
For iChr = 1 To Len(sInp)
iPos = InStr(sInp, Mid(sInp, iChr, 1))
If iPos = iChr Then ' it's new
sChr = Chr(Asc(sChr) + 1)
Mid(Pattern, iChr) = sChr
Else
Mid(Pattern, iChr) = Mid(Pattern, iPos, 1)
End If
Next iChr
End If
End Function
This code looks for the column with header "Quantity Dispensed," then convert the strings in the column by treating the right three digits as decimals, e.i. 00009102" = 9.102
Sub ConvertDec()
Dim colNum As Integer
Dim i As Integer
Dim x As Integer
colNum = WorksheetFunction.Match("Quantity Dispensed", ActiveWorkbook.ActiveSheet.Range("1:1"), 0)
i = 2
Do While ActiveWorkbook.ActiveSheet.Cells(i, colNum).Value <> ""
x = Evaluate(Cells(i, colNum).Value)
Cells(i, colNum) = Int(x / 1000) + (x Mod 1000) / 1000
i = i + 1
Loop
End Sub
I'm getting Overflow error on the line "x = Evaluate..." while executing.
The values in the column are in string form. e.g. "0000120000".
120000 is greater than the maximum value of integer 32768. Use the Long type instead.
Simoco
I have a textbox on a form where the user types some text. Each letter is assigned a different value like a = 1, b = 2, c = 3 and so forth. For example, if the user types "aa bb ccc" the output on a label should be like:
aa = 2
bb = 4
dd = 6
Total value is (12)
I was able to get the total value by looping through the textbox string, but how do I display the total for each word. This is what I have so far:
For letter_counter = 1 To word_length
letter = Mid(txtBox1.Text, letter_counter, 1)
If letter.ToUpper = "A" Then
letter_value = 1
End If
If letter.ToUpper = "B" Then
letter_value = 2
End If
If letter.ToUpper = "C" Then
letter_value = 3
End If
If letter.ToUpper = "D" Then
letter_value = 4
End If
If letter.ToUpper = "E" Then
letter_value = 5
End If
If letter.ToUpper = " " Then
letter_value = 0
End If
totalletter = totalletter + letter_value
Label1.Text = Label1.Text & letter_value & " "
txtBox2.Text = txtBox2.Text & letter_value & " "
Next letter_counter
This simple little routine should do the trick:
Private Sub CountLetters(Input As String)
Label1.Text = ""
Dim total As Integer = 0
Dim dicLetters As New Dictionary(Of Char, Integer)
dicLetters.Add("a"c, 1)
dicLetters.Add("b"c, 5)
dicLetters.Add("c"c, 7)
For Each word As String In Input.Split
Dim wordtotal As Integer = 0
For Each c As Char In word
wordtotal += dicLetters(Char.ToLower(c))
Next
total += wordtotal
'Display word totals here
Label1.Text += word.PadRight(12) + "=" + wordtotal.ToString.PadLeft(5) + vbNewLine
Next
'Display total here
Label1.Text += "Total".PadRight(12) + "=" + total.ToString.PadLeft(5)
End Sub
This should give you an idea:
Dim listOfWordValues As New List(Of Integer)
For letter_counter = 1 To word_length
letter = Mid(txtBox1.Text, letter_counter, 1)
If letter = " " Then
totalletter= totalletter + letter_value
listOfWordValues.Add(letter_value)
letter_value = 0
Else
letter_value += Asc(letter.ToUpper) - 64
End If
Next letter_counter
totalletter = totalletter + letter_value
If Not txtBox1.Text.EndsWith(" ") Then listOfWordValues.Add(letter_value)
txtBox2.Text = txtBox2.Text & string.Join(", ", listOFWordValues);
You can try something like this. Assuming txtBox1 is the string the user enters and " " (space) is the word delimiter:
Dim words As String() = txtBox1.Text.Split(New Char() {" "}, StringSplitOptions.RemoveEmptyEntries)
Dim totalValue As Integer = 0
Dim wordValue As Integer = 0
For Each word As String In words
wordValue = 0
For letter_counter = 1 To word.Length
Dim letter As String = Mid(txtBox1.Text, letter_counter, 1)
Select letter.ToUpper()
Case "A":
wordValue = wordValue + 1
Case "B":
wordValue = wordValue + 2
' And so on
End Select
Next
totalValue = toalValue + wordValue
Next
The above code first takes the entered text from the user and splits it on " " (space).
Next it sets two variables - one for the total value and one for the individual word values, and initializes them to 0.
The outer loop goes through each word in the array from the Split performed on the user entered text. At the start of this loop, it resets the wordValue counter to 0.
The inner loop goes through the current word, and totals up the values of the letter via a Select statement.
Once the inner loop exits, the total value for that word is added to the running totalValue, and the next word is evaluated.
At the end of these two loops you will have calculated the values for each word as well as the total for all the worlds.
The only thing not included in my sample is updating your label(s).
Try this ..
Dim s As String = TextBox1.Text
Dim c As String = "ABCDE"
Dim s0 As String
Dim totalletter As Integer
For x As Integer = 0 To s.Length - 1
s0 = s.Substring(x, 1).ToUpper
If c.Contains(s0) Then
totalletter += c.IndexOf(s0) + 1
End If
Next
MsgBox(totalletter)
I would solve this problem using a dictionary that maps each letter to a number.
Private Shared ReadOnly LetterValues As Dictionary(Of Char, Integer) = GetValues()
Private Shared Function GetValues() As IEnumerable(Of KeyValuePair(Of Char, Integer))
Dim values As New Dictionary(Of Char, Integer)
Dim value As Integer = 0
For Each letter As Char In "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
value += 1
values.Add(letter, value)
Next
Return values
End Function
Public Function CalculateValue(input As String) As Integer
Dim sum As Integer = 0
For Each letter As Char In input.ToUpperInvariant()
If LetterValues.ContainsKey(letter) Then
sum += LetterValues.Item(letter)
End If
Next
Return sum
End Function
Usage example:
Dim sum As Integer = 0
For Each segment As String In "aa bb ccc".Split()
Dim value = CalculateValue(segment)
Console.WriteLine("{0} = {1}", segment, value)
sum += value
Next
Console.WriteLine("Total value is {0}", sum)
' Output
' aa = 2
' bb = 4
' ccc = 9
' Total value is 15