I am writing a VBA code to add +2 to any string of numbers that are put in the function.
It works fine, until it reaches 6 and 7, then it breaks. I really have no clue why that is.
If you are wondering why I am doing this, this is part of an encryption algorithm and it is specifically looking to encrypt digits in a string.
My code is:
Sub AddNumbers()
Dim Nos As String
Dim AddNo As String
Dim Found As Boolean
Dim Split()
Nos = "0-1-2-3-4-5-6-7-8-9-10"
Sheets("Sheet1").Range("U2").Value = Nos
Length = Len(Nos)
ReDim Split(Length)
For i = 1 To Length
Found = False
Split(i) = Mid(Nos, i, 1)
For O = 48 To 55
If Split(i) = Chr(O) Then
Split(i) = Chr(O + 2)
Found = True
Exit For
End If
Next O
If Split(i) = Chr(56) Then
Split(i) = Chr(48)
ElseIf Split(i) = Chr(57) Then
Split(i) = Chr(49)
End If
Next i
AddNo = Join(Split, "")
Sheets("Sheet1").Range("U3").Value = AddNo
End Sub
I would really appreciate an insight to why it is breaking at 6 and 7.
Take me a moment, but you are double adding.
Look at your loop. When you encounter 6 (Char(54)) you add 2 and have 8 (Char(56)).
But then, after your loop you are testing again for same Split(i). Char for 6 and 7 are now accordingly 56 and 57 - so you add another 2 to them.
If Split(i) = Chr(56) And Found = False Then
Split(i) = Chr(48)
ElseIf Split(i) = Chr(57) And Found = False Then
Split(i) = Chr(49)
End If
Use the actual function Split:
Sub AddNumbers()
Dim Nos As String
Dim AddNo As String
Dim Found As Boolean
Dim SplitStr() As String
Nos = "0-1-2-3-4-5-6-7-8-9-10"
Sheets("Sheet1").Range("U2").Value = Nos
SplitStr = Split(Nos, "-")
Dim i As Long
For i = LBound(SplitStr) To UBound(SplitStr)
Dim vlue As String
vlue = StrConv(SplitStr(i), vbUnicode)
Dim substr() As String
substr = Split(Left(vlue, Len(vlue) - 1), vbNullChar)
Dim j As Long
For j = LBound(substr) To UBound(substr)
Select Case substr(j)
Case 8
substr(j) = 0
Case 9
substr(j) = 1
Case Else
substr(j) = substr(j) + 2
End Select
Next j
SplitStr(i) = Join(substr, "")
Next i
AddNo = Join(SplitStr, "-")
Sheets("Sheet1").Range("U3").Value = AddNo
End Sub
The overall problem is that you are using the Chr codes for numbers and not actual numbers. This method only returns 1 digit because a Chr() refers to a list of single characters.
You are going to need to use Split (mySplit = Split(Nos,"-")) to return each number and work with those.
The lines
If Split(i) = Chr(56) Then
Split(i) = Chr(48)
ElseIf Split(i) = Chr(57) Then
Split(i) = Chr(49)
End If
has me confused. You are saying if the value is "8" change to "0" and if it is "9" change to "1"
This is another way to do it:
Sub AddNumbers()
Dim Nos As String, Nos2 As String
Dim NumSplit As Variant
Dim Num As Variant
Dim tmp As String
Dim i As Long
Nos = "0-1-2-3-4-5-6-7-8-9-10"
Sheets("Sheet1").Range("U2").Value = Nos
NumSplit = Split(Nos, "-")
For Each Num In NumSplit
For i = 1 To Len(Num)
tmp = tmp & Mid(Num, i, 1) + 2
Next i
Nos2 = Nos2 & tmp & "-"
tmp = ""
Next Num
Nos2 = Left(Nos2, Len(Nos2) - 1)
Sheets("Sheet1").Range("U3").Value = Nos2
End Sub
It's a bit messy, but shows the basic idea of splitting the original array into the separate numbers.
The For....Next loop inside the For...Each loop takes care of any numbers with more than one digit (giving the 32).
Related
I wrote a function for calc to split a cell before a word containing certain characters:
Function sidx(inputstr) As Integer
Dim newString As String
newString = ""
Dim last_space_idx As String
last_space_idx = 0
Dim l As Integer
'l = (inputstr.Length - 1) was ported from js on google sheets
l = Len(inputstr) - 1
For i = 0 To l
If inputstr(i) = " " Then
last_space_idx = i
End If
If ("’aeiou".Indexof( inputstr(i) ) > 0) Then
sidx = last_space_idx
End If
Next i
sidx = last_space_idx
End Function
for some reason libreoffice has trouble parsing this and complains about mismatched parenthesis or missing Then at the last If statement. Any ideas?
So thanks everyone for all the help - there are many pitfalls porting javascript to libreoffice vba and the interpreter is not that useful... You spotting most of the issues!
Letter extraction was also broken and as I originally believed the brackets was not the real issue!
For closure here is the working version
Function sidx (inputstr As String) As Integer
Dim newString as String
newString = ""
Dim last_space_idx as String
last_space_idx = 0
Dim l as Integer
l = Len(inputstr) -1
For i = 0 to l
letter = Mid(cstr(inputstr),i+1,1)
If letter = " " Then
last_space_idx = i
End If
'If ("’āēīōū".Indexof(inputstr(i))) > 0 Then
If InStr("\’āēīōū",letter) > 0 Then
sidx = last_space_idx
End If
Next i
sidx = last_space_idx
End Function
The following code splits each lines into words and store the first words in each line into array list and the second words into another array list and so on. Then it selects the most frequent word from each list as correct word.
Module Module1
Sub Main()
Dim correctLine As String = ""
Dim line1 As String = "Canda has more than ones official language"
Dim line2 As String = "Canada has more than one oficial languages"
Dim line3 As String = "Canada has nore than one official lnguage"
Dim line4 As String = "Canada has nore than one offical language"
Dim wordsOfLine1() As String = line1.Split(" ")
Dim wordsOfLine2() As String = line2.Split(" ")
Dim wordsOfLine3() As String = line3.Split(" ")
Dim wordsOfLine4() As String = line4.Split(" ")
For i As Integer = 0 To wordsOfLine1.Length - 1
Dim wordAllLinesTemp As New List(Of String)(New String() {wordsOfLine1(i), wordsOfLine2(i), wordsOfLine3(i), wordsOfLine4(i)})
Dim counts = From n In wordAllLinesTemp
Group n By n Into Group
Order By Group.Count() Descending
Select Group.First
correctLine = correctLine & counts.First & " "
Next
correctLine = correctLine.Remove(correctLine.Length - 1)
Console.WriteLine(correctLine)
Console.ReadKey()
End Sub
End Module
My Question: How can I make it works with lines of different number of words. I mean that the length of each lines here is 7 words and the for loop works with this length (length-1). Suppose that line 3 contains 5 words.
EDIT: Accidentally had correctIndex where shortest should have been.
From what I can tell you are trying to see which line is the closest to the correctLine.
You can get the levenshtein distance using the following code:
Public Function LevDist(ByVal s As String,
ByVal t As String) As Integer
Dim n As Integer = s.Length
Dim m As Integer = t.Length
Dim d(n + 1, m + 1) As Integer
If n = 0 Then
Return m
End If
If m = 0 Then
Return n
End If
Dim i As Integer
Dim j As Integer
For i = 0 To n
d(i, 0) = i
Next
For j = 0 To m
d(0, j) = j
Next
For i = 1 To n
For j = 1 To m
Dim cost As Integer
If t(j - 1) = s(i - 1) Then
cost = 0
Else
cost = 1
End If
d(i, j) = Math.Min(Math.Min(d(i - 1, j) + 1, d(i, j - 1) + 1),
d(i - 1, j - 1) + cost)
Next
Next
Return d(n, m)
End Function
And then, this would be used to figure out which line is closest:
Dim correctLine As String = ""
Dim line1 As String = "Canda has more than ones official language"
Dim line2 As String = "Canada has more than one oficial languages"
Dim line3 As String = "Canada has nore than one official lnguage"
Dim line4 As String = "Canada has nore than one offical language"
Dim lineArray As new ArrayList
Dim countArray As new ArrayList
lineArray.Add(line1)
lineArray.Add(line2)
lineArray.Add(line3)
lineArray.Add(line4)
For i = 0 To lineArray.Count - 1
countArray.Add(LevDist(lineArray(i), correctLine))
Next
Dim shortest As Integer = Integer.MaxValue
Dim correctIndex As Integer = 0
For i = 0 To countArray.Count - 1
If countArray(i) <= shortest Then
correctIndex = i
shortest = countArray(i)
End If
Next
Console.WriteLine(lineArray(correctIndex))
I am trying to write an encryption program. The problem I am facing is that I am converting the text to ascii and then adding on the offset. However when it goes past the letter 'z' I want it to warp back to 'a' and go from there.
Sub enc()
Text = TextBox1.Text
finalmessage = ""
letters = Text.ToCharArray
offset = ComboBox1.SelectedItem
For x = LBound(letters) To UBound(letters)
finalmessage = finalmessage + Chr(Asc(letters(x)) + offset)
Next
TextBox2.Text = finalmessage
End Sub
I guess to make it easy to decode afterwards, you should to it somewhat in the line of base64 encoding, first encoding everything to a normalized binary string, then encode in the range you want (since using binary, it has to be something that fits with 2^X).
To match your range, i used a baseset of 32, and a simple encoding decoding example (a bit more verbose that it should be, perhaps)
Module Module1
Dim encodeChars As String = "abcdefghijklmnopqrstuvwxyzABCDEF" ' use 32 as a base
Function Encode(text As String) As String
Dim bitEncoded As String = ""
Dim outputMessage As String = ""
For Each ch As Char In text.ToCharArray()
Dim i As Integer = Convert.ToByte(ch)
bitEncoded &= Convert.ToString(i, 2).PadLeft(8, "0"c)
Next
While bitEncoded.Length Mod 5 <> 0
bitEncoded &= "0"
End While
For position As Integer = 0 To bitEncoded.Length - 1 Step 5
Dim range As String = bitEncoded.Substring(position, 5)
Dim index As Integer = Convert.ToInt32(range, 2)
outputMessage &= encodeChars(index).ToString()
Next
Return outputMessage
End Function
Function Decode(encodedText As String) As String
Dim bitEncoded As String = ""
Dim outputMessage As String = ""
For Each ch In encodedText
Dim index As Integer = encodeChars.IndexOf(ch)
If index < 0 Then
Throw New FormatException("Invalid character in encodedText!")
End If
bitEncoded &= Convert.ToString(index, 2).PadLeft(5, "0"c)
Next
' strip the extra 0's
While bitEncoded.Length Mod 8 <> 0
bitEncoded = bitEncoded.Substring(0, bitEncoded.Length - 1)
End While
For position As Integer = 0 To bitEncoded.Length - 1 Step 8
Dim range As String = bitEncoded.Substring(position, 8)
Dim index As Integer = Convert.ToInt32(range, 2)
outputMessage &= Chr(index).ToString()
Next
Return outputMessage
End Function
Sub Main()
Dim textToEncode As String = "This is a small test, with some special characters! Just testing..."
Dim encodedText As String = Encode(textToEncode)
Dim decodedText As String = Decode(encodedText)
Console.WriteLine(textToEncode)
Console.WriteLine(encodedText)
Console.WriteLine(decodedText)
If Not String.Equals(decodedText, textToEncode) Then
Console.WriteLine("Encoding / decoding failed!")
Else
Console.WriteLine("Encoding / decoding completed succesfully!")
End If
Console.ReadLine()
End Sub
End Module
this then gives the following output?
This is a small test, with some special characters! Just testing...
krugsCzanfzsayjaonwwcBdmebAgkCBufqqhoAlunaqhgBBnmuqhgCdfmnuwcBbamnugcCtbmnAgkCtteeqeuDltoqqhizltoruwCzzofyxa
This is a small test, with some special characters! Just testing...
Encoding / decoding completed succesfully!
I looked at the other links and none seem to help me out. I am writing code for a program that will count all the commas in a phrase. I am not new to programming but I am new to VBA.
Sub examp()
Dim s As String
Dim i, my_c As Integer
i = 0
s = ",jkqk;j,oiheqfjnq;ef,jwhef;ur,jwefun;jwkbnf," '<-------arbitrary, however, when I tried to make it input from a textbox it gave me error 424 as well, so I just defined it as random chars with commas
While i < Len(s)
For i = 0 To Len(s) - 1
j = s.Chars(i) <----------------------------------Error occurs here
If j = "," Then
my_c = my_c + 1
End If
Next i
Wend
Count.Text = "my_c"
End Sub
change j = s.Chars(i) to j = Mid(s,i,1)
in line Dim i, my_c As Integer only my_c is Integer, but i
is Variant. You should declare each variable explicitly: Dim i As Integer, my_c As Integer
not sure what exactly is your Count (maybe textbox), but use
Count.Text = my_c without quotes.
also I can't undersand why do you use two loops? While i < Len(s)
is odd.
For i = 0 To Len(s) - 1 should be For i = 1 To Len(s)
If you want to count commas, there is more efficient way:
Dim s As String
Dim my_c As Integer
s = ",jkqk;j,oiheqfjnq;ef,jwhef;ur,jwefun;jwkbnf,"
my_c = Len(s) - Len(Replace(s, ",", ""))
Or you can try this:
Sub test()
Dim s As String
Dim c
Dim my_c As Long
s = ",jkqk;j,oiheqfjnq;ef,jwhef;ur,jwefun;jwkbnf,"
c = Split(s, ",")
my_c = UBound(c)
Debug.Print my_c
End Sub
Which are the combinations that the sum of each digit is equal to 8 or less, from 1 to 88,888,888?
For example,
70000001 = 7+0+0+0+0+0+0+1 = 8 Should be on the list
00000021 = 0+0+0+0+0+0+2+1 = 3 Should be on the list.
20005002 = 2+0+0+0+5+0+0+2 = 9 Should not be on the list.
Sub Comb()
Dim r As Integer 'Row (to store the number)
Dim i As Integer 'Range
r = 1
For i = 0 To 88888888
If i = 8
'How can I get the sum of the digits on vba?
ActiveSheet.Cells(r, 1) = i
r = r + 1
End If
Else
End Sub
... Is this what you're looking for?
Function AddDigits(sNum As String) As Integer
Dim i As Integer
AddDigits = 0
For i = 1 To Len(sNum)
AddDigits = AddDigits + CInt(Mid(sNum, i, 1))
Next i
End Function
(Just remember to use CStr() on the number you pass into the function.
If not, can you explain what it is you want in a bit more detail.
Hope this helps
The method you suggest is pretty much brute force. On my machine, it ran 6.5min to calculate all numbers. so far a challenge I tried to find a more efficient algorithm.
This one takes about 0.5s:
Private Const cIntNumberOfDigits As Integer = 9
Private mStrNum As String
Private mRng As Range
Private Sub GetNumbers()
Dim dblStart As Double
Set mRng = Range("a1")
dblStart = Timer
mStrNum = Replace(Space(cIntNumberOfDigits), " ", "0")
subGetNumbers 8
Debug.Print (Timer - dblStart) / 10000000, (Timer - dblStart)
End Sub
Private Sub subGetNumbers(intMaxSum As Integer, Optional intStartPos As Integer = 1)
Dim i As Integer
If intStartPos = cIntNumberOfDigits Then
Mid(mStrNum, intStartPos, 1) = intMaxSum
mRng.Value = Val(mStrNum)
Set mRng = mRng.Offset(1)
Mid(mStrNum, intStartPos, 1) = 0
Exit Sub
End If
For i = 0 To intMaxSum
Mid(mStrNum, intStartPos, 1) = CStr(i)
subGetNumbers intMaxSum - i, intStartPos + 1
Next i
Mid(mStrNum, intStartPos, 1) = 0
End Sub
It can be sped up further by about factor 10 by using arrays instead of writing directly to the range and offsetting it, but that should suffice for now! :-)
As an alternative, You can use a function like this:
Function isInnerLowr8(x As Long) As Boolean
Dim strX As String, inSum As Long
isInnerLowr8 = False
strX = Replace(CStr(x), "0", "")
For i = 1 To Len(strX)
Sum = Sum + Val(Mid(strX, i, 1))
If Sum > 8 Then Exit Function
Next i
isInnerLowr8 = True
End Function
Now change If i = 8 to If isInnerLowr8(i) Then.