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.
Related
I'm working on a macro right now and it's producing weird results. The part that is specifically not working is a Min function.
a1RowTemp1 = a1Row
For i = 0 To diff1
intercept = Application.WorksheetFunction.intercept(a(),c())
LinReg1 = (slope * Cells(a1RowTemp1, 1)) + intercept
difference1 = Worksheets("GF9").Cells(a1RowTemp1, 2) - LinReg1
e(i) = difference1
a1RowTemp1 = a1RowTemp1 + 1
Next i
a2RowTemp2 = a2Row
For i = 0 To diff2
intercept2 = Application.WorksheetFunction.intercept(b(), d())
LinReg2 = (slope2 * Cells(a2RowTemp2, 1)) + intercept2
difference2 = Worksheets("GF9").Cells(a2RowTemp2, 2) - LinReg2
f(i) = difference2
a2RowTemp2 = a2RowTemp2 + 1
Next i
Worksheets("Chart").Cells(currentRow, 12) = Application.Max(e())
Worksheets("Chart").Cells(currentRow, 13) = Application.Min(e())
Worksheets("Chart").Cells(currentRow, 25) = Application.Max(f())
Worksheets("Chart").Cells(currentRow, 26) = Application.Min(f())
In the bottom of the code it stores the difference1 and difference2 values in arrays e() and f(). When I use the functions max/min the macro only outputs the correct values for the max functions. I suspect this has something to do with my incorrectly using the arrays.
If e is one dimensional array you should be able to write
Application.WorksheetFunction.Min(e)
Example:
Option Explicit
Public Sub TEST()
Dim e()
e = Array(3, 4, 2, 5)
MsgBox Application.WorksheetFunction.Min(e)
End Sub
If you are still getting the wrong values you need to step though with F8 and check the values being assigned to e in the loop are the expected ones.
You've omitted the declaration and dimensioning of the e and f array. This was an important factor in your problem.
When you declared your e and f as long or double arrays, they were instantiated with zero values.
Dim v() As Double, i As Long
ReDim v(5) '<~~ all zero values
For i = LBound(v) To UBound(v) - 1 '<~~fill all but the last one
v(i) = i + 10
Next i
Debug.Print Application.Min(v) 'zero as v(5) is zero
If you want to ignore array elements that you have not assigned values to, declare the arrays as a variant type.
Dim v() As Variant, i As Long
ReDim v(5) '<~~ all empty values
For i = LBound(v) To UBound(v) - 1 '<~~fill all but the last one
v(i) = i + 10
Next i
Debug.Print Application.Min(v) '10 as v(5) is empty and not considered in Min
An unassigned variant array element is considered empty and is not used in the Min calculation.
Alternately, use one of two methods to remove unused array elements.
'...
'redimension before the loop to the known ubound
redim e(diff1)
For i = 0 To diff1
intercept = Application.WorksheetFunction.intercept(a(),c())
LinReg1 = (slope * Cells(a1RowTemp1, 1)) + intercept
difference1 = Worksheets("GF9").Cells(a1RowTemp1, 2) - LinReg1
e(i) = difference1
a1RowTemp1 = a1RowTemp1 + 1
Next i
'...
'or redimension after the loop with Preserve
For i = 0 To diff2
intercept2 = Application.WorksheetFunction.intercept(b(), d())
LinReg2 = (slope2 * Cells(a2RowTemp2, 1)) + intercept2
difference2 = Worksheets("GF9").Cells(a2RowTemp2, 2) - LinReg2
f(i) = difference2
a2RowTemp2 = a2RowTemp2 + 1
Next i
'i exits with a value 1 greater than diff2
redim preserve f(i-1)
'...
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.
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
I have the following code as a sub in Excel 2010:
i = 2
For j = 1 To num_scenarios
Dim probdiff As Double
Dim OCS_Spend As Double
n = 0
For k = 1 To num_yrs
' These are the calculations and potentially not relevant to my question but here for context
For Each cell In rng
x = Rnd()
'Debug.Print Format(x, "0.00000%")
If cell.Value >= x Then
'Populate the result sheet
Sheets("Event Occurs").Cells(i, 1) = mywksht.Cells(cell.Row, 1)
Sheets("Event Occurs").Cells(i, 2) = mywksht.Cells(cell.Row, 2)
Sheets("Event Occurs").Cells(i, 3) = mywksht.Cells(cell.Row, 3)
Sheets("Event Occurs").Cells(i, 4) = mywksht.Cells(cell.Row, 4)
Sheets("Event Occurs").Cells(i, 5) = mywksht.Cells(cell.Row, 5)
Sheets("Event Occurs").Cells(i, 6) = mywksht.Cells(cell.Row, 6)
Sheets("Event Occurs").Cells(i, 10) = "Event Occurs"
Sheets("Event Occurs").Cells(i, 11) = mywksht.Cells(cell.Row, 11)
Sheets("Event Occurs").Cells(i, 9) = x
Sheets("Event Occurs").Cells(i, 7) = k
Sheets("Event Occurs").Cells(i, 8) = j
Sheets("Event Occurs").Cells(i, 14) = (cell.Value - x) ^ (2)
event_max = Sheets("Event Occurs").Cells(i, 11)
probdiff = probdiff + (cell.Value - x) ^ (2)
If Round(cell / x, 0) >= event_max Then
Sheets("Event Occurs").Cells(i, 12) = event_max
Else
Sheets("Event Occurs").Cells(i, 12) = Round(cell / x, 0)
End If
Duration = Sheets("Event Occurs").Cells(i, 4)
Num_Event = Sheets("Event Occurs").Cells(i, 12)
Spend = Sheets("Event Occurs").Cells(i, 5)
Sheets("Event Occurs").Cells(i, 13) = Num_Event * Spend / Duration
OCS_Spend = OCS_Spend + Num_Event * Spend / Duration
n = n + 1
i = i + 1
End If
Next cell
' End calculations
Next k
Debug.Print j, probdiff / n
probdiff = 0
OCS_Spend = 0
Next j
The output to the immediate window looks like this:
J: MSE:
1 0.194236476623154
2 0.157939130921924
3 0.19825548826238
4 0.384990330451172
5 0.267128221022187
The first column is j (the outer for loop) and represents a scenario. The second column is the mean square error of the data generated by each iteration of the outer j loop. So 1 is the first time the loop runs,2 is the second etc.. The smaller the number in column MSE, the more likely the scenario is to occur.
I want people to be able to limit the number of scenarios (j's) they see to only the most likely in the event they want to run 100 scenarios. So I need a way of sorting the table above to something like this
j: MSE
2 0.157939130921924
1 0.194236476623154
3 0.19825548826238
5 0.267128221022187
4 0.384990330451172
And if someone wanted to see only the top three results, it would be this:
j: MSE
2 0.157939130921924
1 0.194236476623154
3 0.19825548826238
So basically the three most likely out of 5 possible scenarios. I have tried collections and arrays but not dicitonaries (I am still learning how to use these and not sure if they exists in Excel VBA).
Chip Pearson provides a number of very useful functions which can sort arrays, collections, and dictionaries, which are available here:
http://www.cpearson.com/Excel/SortingArrays.aspx
There is too much code there to reproduce here. What I typically do when the need arises is to create a separate module in my VBProject which contains these array helper functions. I have used these extensively in PowerPoint and they worked in that environment with minimal modifications. For Excel, they should work out-of-the-box.
Once you have put the data in an array (I don't see any arrays in your code, so let's assume you have something like Dim MyArray As Variant), and sorted it using those functions, you can do something like this to cut the array down to include only the first x results:
'where "x" is a long/integer represents some user-input or _
limit to the number of results:
ReDim Preserve MyArray(x - 1)
I would use arrays rather than collections or dictionaries.
Why not Collections? Collections are useful and would arguably do the job, here. However, whereas we can "resize" the array in a single ReDim Preserve statement, you cannot do that with a Collection object; you would instead have to use iteration. While this is not overly complicated, it does seem a bit clunkier. (You could of course do some tests on performance, but unless you are dealing with very large sets of data, I would not expect a noticeable gain either way).
Sub testCollection()
Dim coll As New Collection
Dim i As Integer
For i = 1 To 10
coll.Add i
Next
Dim x As Integer 'The maximum number of results you want to return:
x = 4
Do Until coll.Count = x
coll.Remove (coll.Count)
Loop
End Sub
Why not dictionaries? While a dictionary's .Keys returns a one-dimensional array of values, in order to avoid iteration (like in the collection object) you would still need to transfer these to an array:
MyArray = dict.Keys()
ReDim Preserve MyArray(x-1)
Further, the dictionary object holds unique key values, so these are not good to use if you anticipate that there may be duplicate values that you need to store.
One option is to use a System.Collections.ArrayList since this object directly supports a Sort method. The Object is "borrowed" from VB.NET.
EDIT#1
Here is a sample:
Sub SortDemo()
s = Array("Larry", "Moe", "Curley", "Manny", "Zack", "Jack")
L = LBound(s)
U = UBound(s)
With CreateObject("System.Collections.ArrayList")
For k = L To U
.Add s(k)
Next k
.Sort
s = .toarray
End With
msg = ""
For k = L To U
msg = msg & s(k) & vbCrLf
Next k
MsgBox msg
End Sub
and here are the references in place:
For more information see:
Ozgrid Material