I am working a code, and I have a problem with Excel's XIRR function.
You have a matrix with 2 columns (dates and amounts), so the inputs are the matrix, a date, and a quantity. Inside the code it takes the values below the date you used as input, makes a new array with those values, and add also the date and amount you entered as inputs. And the output should be the XIRR of that array. It doesn´t seem to work. It works with IRR, with dates are an important input. Does someone know how to fix this problem? Thanks in advance!
Function Retorno(matriz As Range, dia As Date, valuacion As Double) As Double
Dim Datos As Range
Dim Aux1()
Dim Aux2()
Dim i, j, m, n As Integer
Set Datos = matriz
j = 0
For i = 1 To Datos.Rows.Count
If Datos(i, 1) <= dia Then
j = j + 1
End If
Next i
ReDim Aux1(1 To j + 1)
ReDim Aux2(1 To j + 1)
For n = 1 To j + 1
Aux1(n) = Datos(n, 2)
Next n
Aux1(j + 1) = valuacion
For m = 1 To j + 1
Aux2(m) = Datos(m, 1)
Next m
Aux2(j + 1) = dia
Retorno = WorksheetFunction.Xirr(Aux1, Aux2)
End Function
Your last Aux2(j + 1) = dia is overwriting the second date in the array with the first date, giving you two identical dates in the date array.
Possibly you want to delete that line.
The other possible answer to this problem is to convert the date to numbers if you do this: Aux2(m) = Datos(m, 1)*1 XIRR will work too.
Related
I have three arrays, DueDateArr, MilestoneDollarsArr, MilestoneNameArr.
I wish to sort DueDateArr chronologically and using the same sorting procedure also sort the other arrays in the same order. I used How can I sort dates in an array in vba? with additional array sorting parts but this doesn't seem to work correctly. In the output everything is ok except for the first entry being the wrong date.
Alternatively if its possible I'd like to use something like a linked list that they have in java that is a sortable multiple dimensional array with different variable types.
Data is as follows:
Sorted data is as follows: (note first entry is incorrect)
Dim TotalCountMinusOneForArrays as Integer
Dim DueDateArr() As Date
Dim MilestoneDollarsArr() As Double
Dim MilestoneNameArr() As String
Dim DueDateValue As Date
Dim MilestoneNameValue As String
Dim DueDateInfo As Date
Dim MilestoneDollarsInfo As Double
Dim MilestoneNameInfo As String
Dim i As Long, j As Long
i = 0
j = 0
For j = 2 To TotalCountMinusOneForArrays
DueDateInfo = DueDateArr(j)
MilestoneDollarsInfo = MilestoneDollarsArr(j)
MilestoneNameInfo = MilestoneNameArr(j)
For i = j - 1 To 1 Step -1
If (DueDateArr(i) <= DueDateInfo) Then GoTo Sort
DueDateArr(i + 1) = DueDateArr(i)
MilestoneDollarsArr(i + 1) = MilestoneDollarsArr(i)
MilestoneNameArr(i + 1) = MilestoneNameArr(i)
Next i
i = 0
Sort: DueDateArr(i + 1) = DueDateInfo
MilestoneDollarsArr(i + 1) = MilestoneDollarsInfo
MilestoneNameArr(i + 1) = MilestoneNameInfo
Next j
The simple approach would be to programmatically sort your data first using built-in sort functionality and then populate the array. However, when that is not an option, the two popular solutions are Bubble Sort or Merge Sort
Bubble sort being the easiest to apply:
Do Until bSort = False
bSort = False
For i = 0 to UBound(ArrToSort) - 1
If ArrToSort(i + 1) < ArrToSort(i) Then
tempVal = ArrToSort(i)
ArrToSort(i) = ArrToSort(i + 1)
ArrToSort(i + 1) = tempVal
bSort = True
End If
Next i
Loop
For your case, if you wanted to do it multidimensionally instead of with several arrays you could do this
Do Until bSort = False
bSort = False
For i = 0 to UBound(ArrToSort) - 1
If CDate(ArrToSort(i + 1, 1)) < CDate(ArrToSort(i, 1)) Then
for i2 = 1 to 3
tempVal(1, i2) = ArrToSort(i, i2)
ArrToSort(i, i2) = ArrToSort(i + 1, i2)
ArrToSort(i + 1) = tempVal(1, i2)
next i2
bSort = True
End If
Next i
Loop
Where ArrToSort(i, 1) is your date data in your multidimensional array.
EDIT:
Worth mentioning, to my knowledge there sadly is no fast way to sort arrays in excel VBA other than the methods provided.
EDIT 2:
Added CDate() around the date values of the array in the Bubble Sort.
I am new with VBA and trying to do a trinomial option pricing tree with parameters from -n to n defined. How can I rewrite my VBA function with a double loop to provide all output as it seems to only show the value of S. In the end I want to sum all values and discount them but I cannot get past my double loop providing only one output. If I put the MsgBox between k and i loop it returns nothing. Please can someone assist getting this to work as I don't have the hang of VBA yet.
Public Function LoopTest(S As Double, u As Double, n As Integer)
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim St() As Double
ReDim St(2 * n + 1)
For k = 0 To n Step 1
For i = -k To k Step 1
St(i, k) = S * u ^ i
Debug.Print St(i, k)
MsgBox ("DebugToPrint")
' Payoff(i,k) = Application.WorksheetFunction.Max((St(i,k) - 20), 0)
Next i
Next k
' For i from n to 2 step -1
' For j from 1 to n - 2
' Payoff(i - 1, j) = Payoff(i, j) + Payoff(i, j + 1) + Payoff(i, j + 2)
' Next i
' Next k
LoopTest = St()
End Function
How do I get output
k=0 St = S*u^0
k=1 St = S*u^-1 , St = S*u^0 , St = S*u^1
k=2 St = S*u^-2 , St = S*u^-1 , St = S*u^0 , St = S*u^1 , St = S*u^2
etc and then sum everything afterwards as output?
I'm not totally following the example but from the description it sounds like you're interested in a recursive process. It can be tricky and will leave you in an endless loop if you're not careful. Does this previous post help you? VBA recursive "For loops" Permutation?
I have a function which returns a stock price for a given day. If the value returned is empty then a Do Until loop decreases the date by 1 and calls the function again with the new date. Once Do Until condition is met and no price has been found, the price is set to 0.
Code snippet below illustrates how a working version of this code works:
Dim Date1 As Date
Dim r As Variant
Dim Price1 As Variant
Dim arg1 As Variant
Dim arg2 As Variant
Dim counter As Integer
r = Function1(arg1, arg2, Date1, Date1)
Price1 = r(0, 0)
Do Until IsEmpty(Price1) = False And counter <= 10
Date1 = Date1 - 1
counter = counter + 1
r = Function1(arg1, arg2, Date1, Date1)
Price1 = r(0, 0)
If counter = 10 Then
Price1 = 0
End If
Loop
Now, i am trying to recreate this code so that i can pass two dates into it and retrieve two different prices for their respective days (having also gone through the Do Until routine in the case of empty results).
Thus far, I've been trying to use the 'For' loop along with various 'If' Statements to pass the arguments in the correct way but none have worked.
My latest attempt along with the Logic can be seen below:
On iteration 1, pass Date1 into function, retrieve Price 1 and assign this to the variable PriceT.
On iteration 2, pass Date2 into function, retrieve Price 2 and assign this to the variable PriceTX, then Exit loop.
Dim Dates(0 To 1) As Date
Dim Count As Integer
Dim counter, PriceT, PriceTX, arg1, arg2, x, y, j As Variant
For Count = 1 To 2
If Count = 1 Then j = Date1 Else j = Date2
x = Function1(arg1, arg2, j, j)
y = x(0,0)
Do Until IsEmpty(y) = False And counter <= 10
j = j - 1
counter = counter + 1
x = Function1(arg1, arg2, j, j)
y = x(0, 0)
If counter = 10 Then
y = 0
End If
Loop
If Count = 1 Then y = PriceT Else y = PriceTX
Next
I would like to mention that i'm seeking a neat and highly optimized solution, i'm trying to avoid replicating the working code twice and doubling the amount of lines (though i know that would work as I've already tried it.)
I don't really understand how else to approach this. Any advice will be greatly appreciated.
I may have missed the point, but you may simply want:
PriceT = func1(Date1)
PriceTX = func1(Date2)
Function func1(j As Date) As Variant
x = Function1(arg1, arg2, j, j)
y = x(0, 0)
Do Until IsEmpty(y) = False And counter <= 10
j = j - 1
counter = counter + 1
x = Function1(arg1, arg2, j, j)
y = x(0, 0)
If counter = 10 Then
y = 0
End If
Loop
func1 = y
End Function
I have a set which has an unknown number of objects. I want to associate a label to each one of these objects. Instead of labeling each object with a number I want to label them with letters.
For example the first object would be labeled A the second B and so on.
When I get to Z, the next object would be labeled AA
AZ? then BA, BB, BC.
ZZ? then AAA, AAB, AAC and so on.
I'm working using Mapbasic (similar to VBA), but I can't seem to wrap my head around a dynamic solution. My solution assumes that there will be a max number of objects that the set may or may not exceed.
label = pos1 & pos2
Once pos2 reaches ASCII "Z" then pos1 will be "A" and pos2 will be "A". However, if there is another object after "ZZ" this will fail.
How do I overcome this static solution?
Basically what I needed was a Base 26 Counter. The function takes a parameter like "A" or "AAA" and determines the next letter in the sequence.
Function IncrementAlpha(ByVal alpha As String) As String
Dim N As Integer
Dim num As Integer
Dim str As String
Do While Len(alpha)
num = num * 26 + (Asc(alpha) - Asc("A") + 1)
alpha = Mid$(alpha, 2,1)
Loop
N = num + 1
Do While N > 0
str = Chr$(Asc("A") + (N - 1) Mod 26) & str
N = (N - 1) \ 26
Loop
IncrementAlpha = str
End Function
If we need to convert numbers to a "letter format" where:
1 = A
26 = Z
27 = AA
702 = ZZ
703 = AAA etc
...and it needs to be in Excel VBA, then we're in luck. Excel's columns are "numbered" the same way!
Function numToLetters(num As Integer) As String
numToLetters = Split(Cells(1, num).Address(, 0), "$")(0)
End Function
Pass this function a number between 1 and 16384 and it will return a string between A and XFD.
Edit:
I guess I misread; you're not using Excel. If you're using VBA you should still be able to do this will the help of an reference to an Excel Object Library.
This should get you going in terms of the logic. Haven't tested it completely, but you should be able to work from here.
Public Function GenerateLabel(ByVal Number As Long) As String
Const TOKENS As String = "ZABCDEFGHIJKLMNOPQRSTUVWXY"
Dim i As Long
Dim j As Long
Dim Prev As String
j = 1
Prev = ""
Do While Number > 0
i = (Number Mod 26) + 1
GenerateLabel = Prev & Mid(TOKENS, i, 1)
Number = Number - 26
If j > 0 Then Prev = Mid(TOKENS, j + 1, 1)
j = j + Abs(Number Mod 26 = 0)
Loop
End Function
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