I am trying to create the function for this purpose: I have a year of birth list, I want to take out the last two numbers of that year and make a sum of them. If this sum is less than 10, it will be the result I need. If the result is more than 10 (ex: 9+9 = 18), I will separate this two digits (1 and 8) and make a sum of them (1+8=9. This is less than 10, so it will be my result)
This is my code, but it only give me the result of the first split and sum (18 in this example):
Function test(yob as range) as integer
Dim sum, i, j, i2, j2 as integer
i = mid(yob, 3, 1)
j = right(yob, 1)
sum = i + j
If sum < 10 then
test = sum
Else:
i2 = left(sum, 1)
j2 = right(sum, 1)
test = i2 + j2
End If
End function
Sub test()
Debug.Print getSum(9, 9)
'/ Prints 9
Debug.Print getSumShort(7, 7)
'/ Prints 5
End Sub
Public Function getSum(x As Long, y As Long)
Dim res As Long
res = x + y
Do While res > 10 '/ Keep repeating till its greater than 10
res = (res \ 10) + (res Mod 10)
Loop
getSum = res
End Function
'/ Another way using 9 as divider.
Public Function getSumShort(x As Long, y As Long)
Dim res As Long
res = (x + y) Mod 9
getSum = IIf(res = 0, 9, res)
End Function
Function sum2d(year)
sum2d=IIf(year mod 100, (year - 1) Mod 9 + 1, 0)
End Function
Sub Test
For Each v in Array(1980, 2001, 2017)
Debug.Print v; "=>"; sum2d(v)
Next
Next
Related
I'm trying to write a recursive function so that it calculates the sum of the products of the combinations of values in a dynamic array. Right now I've been trying to make it work for a simpler case, but I really don't quite understand the structure I should follow for a recursive function. In this case there's supposed to be the sum of 28 two factor products, resulting 1.4
Sub SuPC()
Dim k As Long
Dim s As Long
Dim i As Long
Dim j As Long
k = 8
s = 2
HSum i, j, s, k
End Sub
Function HSum(i As Long, j As Long, s, k) As Double
Dim P As Variant
Dim z() As Double
Dim Tot As Double
ReDim z(0 To (k * s) - 1)
P = Array(1 / 2, 1 / 3, 1 / 4, 1 / 5, 1 / 6, 1 / 7, 1 / 8, 1 / 9)
If i <= k Then
HSum i + 1, j, s, k
If j <= s Then
HSum i, j + 1, s, k
If z(i) = 0 Then z(i) = 1
z(i) = P(j) * z(i)
End If
Tot = z(i) + Tot
End If
Range("J11") = Tot
End Function
If s and k were low fixated values, I could use For loops but the point is for them to be variable.
You should try to use tail recursion as this is just a sum of the products,
see here an example for tail recursion factoring.
Public Function fact_tail(n As Double) As Double
'Tail Recursion
'fact 4 = 4 * fact 3
' = 4* 3 * fact 2
' = 4* 3 * 2 * fact 1
' = 4* 3 * 2 * 1
'fact 4 = go(4, 1)
' = go((n - 1), (a * n))
' = go((4-1),(1*4))
' = go(3, 4)
' = go(3-1, 3*4)
' = go(2, 12)
' = go(2-1, 12*2)
' = go(1, 24)
' = 4* 3 * 2 * 1 = 24
fact_tail = go_fact(n, 1)
End Function
Private Function go_fact(n, a)
If n <= 1 Then
go_fact = a
Else
go_fact = go_fact((n - 1), (a * n))
End If
End Function
I am trying to make a quick sort however i am having trouble with a stack overflow exception in VB.net.
The sort works correctly when x = 3, intermittently when x = 5 and on one occasion sorted half of the list when x = 10.
Please advise, thanks
Dim x As Integer = 10
Dim numArrray(x - 1) As Integer
For i = 0 To x - 1
Randomize()
numArrray(i) = CInt(Rnd() * 9)
Next
Quicksort(numArrray, 0, numArrray.Length - 1)
For i = 0 To x - 1
Console.Write(numArrray(i))
Next
Console.ReadLine()
End Sub
Sub Quicksort(ByVal array() As Integer, ByVal min As Integer, ByVal max As Integer)
Dim pivot As Integer
If min < max Then
pivot = partition(array, min, max)
Quicksort(array, min, pivot - 1)
Quicksort(array, pivot + 1, max)
End If
End Sub
Function partition(ByVal array() As Integer, ByVal min As Integer, ByVal max As Integer) As Integer
Dim pivot As Integer = array(max)
Dim count As Integer = min - 1
Dim placeholder As Integer
For i = min To max - 1
If array(i) < pivot Then
count += 1
placeholder = array(count)
array(count) = array(i)
array(i) = placeholder
End If
Next
If array(max) < array(count + 1) Then
placeholder = array(count + 1)
array(count + 1) = array(max)
array(max) = placeholder
End If
Return count
End Function
Since its a stack overflow it will be in the nested calls to Quicksort, looking at partition I think you have a bounds error, as per this version of the algorithm en.wikipedia.org/wiki/Quicksort you should return count + 1 from partition, on your current implementation count can start below min and stay that way which would be an infinite regression as your nested call would have the same inputs (ie if you return count = min - 1 then you do a recursive call back to Quicksort(array, pivot + 1, max) == Quicksort(array, min, max)
I have this code below, and I'm getting an overflow error at the line:
s = s + (x Mod 10) [first line in the Do Loop]
Why? I declared x and s to be of type Double. Adding two doubles, why is this not working?
Thanks for your help.
Public Sub bidon1()
Dim i As Double, x As Double, s As Double, k As Byte, h As Byte
Dim y(1 To 6) As Double
For i = 1 To 1000000
x = i ^ 3
Do
s = s + (x Mod 10)
x = x \ 10
Loop Until x = 0
If s = x Then
k = k + 1
y(k) = x
If y(6) > 0 Then
For h = 1 To 6
Debug.Print y(h)
Next
Exit Sub
End If
End If
Next
End Sub
The problem is that the VBA mod operator coerces its arguments to be integers (if they are not already so). It is this implicit coercion which is causing the overflow. See this question: Mod with Doubles
On Edit:
Based on your comments, you want to be able to add together the digits in a largish integer. The following function might help:
Function DigitSum(num As Variant) As Long
'Takes a variant which represents an integer type
'such as Integer, Long or Decimal
'and returns the sum of its digits
Dim sum As Long, i As Long, s As String
s = CStr(num)
For i = 1 To Len(s)
sum = sum + Val(Mid(s, i, 1))
Next i
DigitSum = sum
End Function
The following test sub shows how it can be used to correctly get the sum of the digits in 999999^3:
Sub test()
Dim x As Variant, y As Variant
Debug.Print "Naive approach: " & DigitSum(999999 ^ 3)
y = CDec(999999)
x = y * y * y
Debug.Print "CDec approach: " & DigitSum(x)
End Sub
Output:
Naive approach: 63
CDec approach: 108
Since 999999^3 = 999997000002999999, only the second result is accurate. The first result is only the sum of the digits in the string representation of the double 999999^3 = 9.99997000003E+17
I am banging my head against the wall for a while now trying different techniques.
None of them are working well.
I have two strings.
I need to compare them and get an exact percentage of match,
ie. "four score and seven years ago" TO "for scor and sevn yeres ago"
Well, I first started by comparing every word to every word, tracking every hit, and percentage = count \ numOfWords. Nope, didn't take into account misspelled words.
("four" <> "for" even though it is close)
Then I started by trying to compare every char in each char, incrementing the string char if not a match (to count for misspellings). But, I would get false hits because the first string could have every char in the second but not in the exact order of the second. ("stuff avail" <> "stu vail" (but it would come back as such, low percentage, but a hit. 9 \ 11 = 81%))
SO, I then tried comparing PAIRS of chars in each string. If string1[i] = string2[k] AND string1[i+1] = string2[k+1], increment the count, and increment the "k" when it doesn't match (to track mispellings. "for" and "four" should come back with a 75% hit.) That doesn't seem to work either. It is getting closer, but even with an exact match it is only returns 94%. And then it really gets screwed up when something is really misspelled. (Code at the bottom)
Any ideas or directions to go?
Code
count = 0
j = 0
k = 0
While j < strTempName.Length - 2 And k < strTempFile.Length - 2
' To ignore non letters or digits '
If Not strTempName(j).IsLetter(strTempName(j)) Then
j += 1
End If
' To ignore non letters or digits '
If Not strTempFile(k).IsLetter(strTempFile(k)) Then
k += 1
End If
' compare pair of chars '
While (strTempName(j) <> strTempFile(k) And _
strTempName(j + 1) <> strTempFile(k + 1) And _
k < strTempFile.Length - 2)
k += 1
End While
count += 1
j += 1
k += 1
End While
perc = count / (strTempName.Length - 1)
Edit: I have been doing some research and I think I initially found the code from here and translated it to vbnet years ago. It uses the Levenshtein string matching algorithm.
Here is the code I use for that, hope it helps:
Sub Main()
Dim string1 As String = "four score and seven years ago"
Dim string2 As String = "for scor and sevn yeres ago"
Dim similarity As Single =
GetSimilarity(string1, string2)
' RESULT : 0.8
End Sub
Public Function GetSimilarity(string1 As String, string2 As String) As Single
Dim dis As Single = ComputeDistance(string1, string2)
Dim maxLen As Single = string1.Length
If maxLen < string2.Length Then
maxLen = string2.Length
End If
If maxLen = 0.0F Then
Return 1.0F
Else
Return 1.0F - dis / maxLen
End If
End Function
Private Function ComputeDistance(s As String, t As String) As Integer
Dim n As Integer = s.Length
Dim m As Integer = t.Length
Dim distance As Integer(,) = New Integer(n, m) {}
' matrix
Dim cost As Integer = 0
If n = 0 Then
Return m
End If
If m = 0 Then
Return n
End If
'init1
Dim i As Integer = 0
While i <= n
distance(i, 0) = System.Math.Max(System.Threading.Interlocked.Increment(i), i - 1)
End While
Dim j As Integer = 0
While j <= m
distance(0, j) = System.Math.Max(System.Threading.Interlocked.Increment(j), j - 1)
End While
'find min distance
For i = 1 To n
For j = 1 To m
cost = (If(t.Substring(j - 1, 1) = s.Substring(i - 1, 1), 0, 1))
distance(i, j) = Math.Min(distance(i - 1, j) + 1, Math.Min(distance(i, j - 1) + 1, distance(i - 1, j - 1) + cost))
Next
Next
Return distance(n, m)
End Function
Did not work for me unless one (or both) of following are done:
1) use option compare statement "Option Compare Text" before any Import declarations and before Class definition (i.e. the very, very first line)
2) convert both strings to lowercase using .tolower
Xavier's code must be correct to:
While i <= n
distance(i, 0) = System.Math.Min(System.Threading.Interlocked.Increment(i), i - 1)
End While
Dim j As Integer = 0
While j <= m
distance(0, j) = System.Math.Min(System.Threading.Interlocked.Increment(j), j - 1)
End While
First off, here's my code:
Sub SimulatePortfolio()
Dim lambda As Double
Dim num As Integer
Dim cycles As Long
Column = 12
q = 1.5
lambda = 0.05
cycles = 100000
Dim data(1 To 100000, 1 To 10) As Integer
Dim values(1 To 10) As Double
For i = 1 To 10
values(i) = 0
Next i
temp = lambda
For i = 1 To cycles
lambda = temp
num = 10
t = 0
Dim temps(1 To 10) As Integer
For k = 1 To 10
temps(k) = 1000
Next k
Do While (t < 10 And num > 0)
t = t + tsim(lambda, num)
For j = 1 To 10
If (j > t) Then
temps(j) = temps(j) - 50
End If
Next j
num = num - 1
If (num <= 0) Then
Exit Do
End If
lambda = lambda * q
Loop
For l = 1 To 10
values(l) = values(l) + temps(l)
data(i, l) = temps(l)
Next l
Next i
For i = 1 To 10
Cells(i + 1, Column) = values(i) / cycles
'Problem occurs on this line:
Cells(i + 1, Column + 1).Value = Application.WorksheetFunction.Var(Application.WorksheetFunction.Index(data, i, 0))
Next i
End Sub
Function tsim(lambda As Double, num As Integer) As Double
Dim v As Double
Dim min As Double
Randomize
min = (-1 / lambda) * Log(Rnd)
For i = 1 To (num - 1)
Randomize
v = (-1 / lambda) * Log(Rnd)
If (min > v) Then
min = v
End If
Next i
tsim = min
End Function
When I set the value for cycles to 10000, it runs fine without a hitch. When I go to 100000 cycles, it gets an Error 13 at the indicated line of code.
Having been aware that Application.Tranpose is limited to 65536 rows with variants (throwing the same error) I tested the same issue with Index
It appears that Application.WorksheetFunction.Index also has a limit of 65536 rows when working with variants - but standard ranges are fine
So you will need to either need to dump data to a range and work on the range with Index, or work with two arrays
Sub Test()
Dim Y
Dim Z
'works in xl07/10
Debug.Print Application.WorksheetFunction.Index(Range("A1:A100000"), 1, 1)
Y = Range("A1:A65536")
`works
Debug.Print Application.WorksheetFunction.Index(Y, 1, 1)
'fails in xl07/10
Z = Range("A1:A65537")
Debug.Print Application.WorksheetFunction.Index(Z, 1, 1)
End Sub