Sorting Arrays or collections - vba

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

Related

Sort multiple arrays using a sort by date function

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.

Min function not working properly in VBA

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)
'...

How come VBA excel keeps running the statement inside a conditional statement even if it is false?

I am trying to create an automatic filling of the payroll spreadsheet I created. However, no matter how much I try it the value of z = 1 all the time even if the logic returns FALSE values (I validated this using MsgBox).
My goal in this code is to check whether there is already a record in another sheet. If there isn't it will automatically add the record with the appropriate details based on the available data.
Below is the full VBA code (Note code is incomplete so it is a bit unpolished still):
Option Explicit
Public p As Long
Sub test()
Dim Total_rows_PR As Long
Dim Total_rows_DTR As Long
Total_rows_PR = Worksheets("Payroll - Regular").Range("B" & Rows.Count).End(xlUp).Row
Total_rows_DTR = Worksheets("DTR").Range("B" & Rows.Count).End(xlUp).Row
Dim q As Long
Dim j As Long
Dim z As Long
For j = 1 To Total_rows_DTR - 1
For q = 1 To Total_rows_PR + p - 2
If Worksheets("DTR").Cells(1 + j, 33) = Worksheets("Payroll - Regular").Cells(2 + q, 1) Then
If Worksheets("DTR").Cells(1 + j, 34) = Worksheets("Payroll - Regular").Cells(2 + q, 2) Then
If Worksheets("DTR").Cells(1 + j, 2) = Worksheets("Payroll - Regular").Cells(2 + q, 3) Then
z = 1
Exit For
End If
End If
End If
Next q
' Below is where the assignment should happen but only returns a blank cell
If z = 0 Then Worksheets("Payroll - Regular").Cells(Total_rows_PR + 1 + p, 1) = Worksheets("DTR").Cells(1 + j, 33)
If z = 0 Then Worksheets("Payroll - Regular").Cells(Total_rows_PR + 1 + p, 2) = Worksheets("DTR").Cells(1 + j, 34)
If z = 0 Then Worksheets("Payroll - Regular").Cells(Total_rows_PR + 1 + p, 3) = Worksheets("DTR").Cells(1 + j, 2)
If z = 0 Then p = p + 1
z = 0
Next j
End Sub
Update: I realized that even if the conditions are not being a met in the first portion of If-Then loops, the value of z is set to 1 for no reason. This is the reason why it won't assign values. However, I do not see why it keeps assigning to 1.
Update#2: #ShaiRado
So the first image is where data is encoded (not shown in image because it is in the leftmost part of the spreadsheet, but basically it inputs the name of the person, date, and the daily time record (DTR) of the person). When the data is encoded, it will automatically indicate what month and year it is based on the helper column AG month and column AH for year. Somewhere in the start of the same worksheet at column B is where the name of the person is. All of these 3 will be used.
This second image is where the summaries are computed. If there is an entry for a specific person at a certain month and year and it is not located in this worksheet, it will automatically fill in that person's name as well as the month and year. Basically that's what the code i'm trying to create does.
The output is a fully automated spreadsheet that only requires data entry in the DTR sheet. All computations already have their corresponding formulas.
First: You have a really strange way of writing your if-statements.
I think what you mean is
For q = 1 To Total_rows_PR + p
If Worksheets("DTR").Cells(1 + j, 33) = Worksheets("Payroll - Regular").Cells(2 + q, 1) _
And Worksheets("DTR").Cells(1 + j, 34) = Worksheets("Payroll - Regular").Cells(2 + q, 2) _
And Worksheets("DTR").Cells(1 + j, 2) = Worksheets("Payroll - Regular").Cells(2 + q, 3) Then
z = 1
Exit For ' Once found, z stays 1 so you don't have to continue the inner loop.
End If
Next q
Second: I am not sure what exactly you want to achieve, but as far as I understand, your problem is that you are looping to far. At the last iteration of the outer loop, your accessing row 1 + j of sheet DTR which is empty at that time, and you are accessing row 2 + q (which is the same as 2 + Total_rows_PR + p) - also empty (and comparing the two emtpy lines sets z to 1).
A variable is never set for no reason. Is is maybe set and you don't understand the reason.
Debug your code step by step, watch where it behaves different as you expect and find the reason why it does what is does.

Excel VBA error 438 : object doesn't support this property or method

Please help , this is my first try to code something useful by VBA and I am self-learning now. And I got that above error . Please help
Sub Bezier()
Dim C As Double, k As Integer, ansx As Double, ansy As Double, t As Double, n As Integer
n = 3
For i = 0 To 100
t = i * 0.01
ansx = 0
ansy = 0
For k = 0 To n
C = (WorksheetFunction.Fact(n) / WorksheetFunction.Fact(k)) / WorksheetFunction.Fact(n - k)
ansx = ansx + Cells(k + 2, 1).Value * C * WorksheetFunction.Power(t, k) * WorksheetFunction.Power(1 - t, n - k)
ansy = ansy + Cells(k + 2, 2).Value * C * WorksheetFunction.Power(t, k) * WorksheetFunction.Power(1 - t, n - k)
Next
Cells(i + 2, 6).Value = ansx
Cells(i + 2, 7).Value = ansy
Next
End Sub
First of all, you should know, that some of functions, used on the worksheet, have limitations. So my point is avoid of using them in VBA, if it is not necessary.
For example, function POWER() returns error on attempt to raise a zero to zero. An alternative is to use 0 ^ 0 combination, which is exactly doing the same, but looks more simply and operates without such error. But also there is no embedded alternative in VBA to the FACT() function, so you can use it, or simply add your own function factor() - it's uppon your choise.
If you just have started learning VBA, I would recomend you to use Option Explicit. It will help you to find out, which variables are not defined, and sometimes to avoid errors related to variable names missprint.
Here is your code, fixed and a little bit optimized:
Option Explicit' It is an option that turns on check for every used variable to be defined before execution. If this option is not defined, your code below will find undefined variables and define them when they are used. Good practice is to use this option, because it helps you, for example to prevent missprinting errors in variable names.
Sub Bezier()
Dim C as Double , t As Double
Dim k As Long, n As Long, i As Long
n = 3
For i = 0 To 100
t = i * 0.01
Cells(i + 2, 6) = 0
Cells(i + 2, 7) = 0
For k = 0 To n
C = (WorksheetFunction.Fact(n) / WorksheetFunction.Fact(k)) / WorksheetFunction.Fact(n - k)
Cells(i + 2, 6) = Cells(i + 2, 6).Value + Cells(k + 2, 1).Value * C * (t ^ k) * ((1 - t) ^ (n - k))
Cells(i + 2, 7) = Cells(i + 2, 7).Value + Cells(k + 2, 2).Value * C * (t ^ k) * ((1 - t) ^ (n - k))
Next
Next
End Sub
UPDATE
Here are some examples of factorial calculations.
Public Function fnFact(number) ' a simple cycle example of Factorial function
Dim tmp As Long ' new temporary variable to keep the "number" variable unchanged
tmp = number
fnFact = number
While tmp > 1
tmp = tmp - 1
fnFact = fnFact * tmp
Wend
End Function
Public Function fnFactR(number) ' a simple example of recursive function for Factorial calculation
If number > 0 Then
fnFactR = fnFactR(number - 1) * number ' function calls itself to continue calculations
Else
fnFactR = 1 ' function returns {1} when calculations are over
End If
End Function
Sub Factor_test() 'RUN ME TO TEST ALL THE FACTORIAL FUNCTIONS
Dim number As Long
number = 170 ' change me to find Factorial for a different value
MsgBox "Cycle Factorial:" & vbNewLine & number & "!= " & fnFact(number)
MsgBox "WorksheetFunction Factorial:" & vbNewLine & number & "!= " & WorksheetFunction.Fact(number)
MsgBox "Recursive Factorial:" & vbNewLine & number & "!= " & fnFactR(number)
End Sub
All those functions are available to calculate Factorial only for numbers before 170 inclusively, because of large result value.
So for my PC the limitation for WorksheetFunction.Fact() function is also 170.
Let me know, if your PC has different limitation for this function, - it's quite interesting thing. :)
UPDATE2
It is recomended to use Long data type instead of Integer each type when integer (or whole number) variable is needed. Long is slightly faster, it has much wider limitations and costs no additional memory. Here are proof links:
1. MSDN:The Integer, Long, and Byte Data Types
2. ozgrid.com:Long Vs Integer
3. pcreview.co.uk:VBA code optimization - why using long instead of integer?
Thanks for #Ioannis and #chris neilsen for the information about Long data type and proof links!
Good luck in your further VBA actions!
I can't find a pow method on the WorksheetFunction object. There is a Power method though. Perhaps you meant that?

Working with Excel ranges and arrays

In VBA, I can easily pull in an sheet\range into an array, manipulate, then pass back to the sheet\range. I'm having trouble doing this in VB.Net though.
Here's my code.
Rng = .Range("a4", .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count))
Dim SheetArray(,) As Object = DirectCast(Rng.Value(Excel.XlRangeValueDataType.xlRangeValueDefault), Object(,))
For X As Integer = 0 To SheetArray.GetUpperBound(0)
If IsNothing(SheetArray(X, 0)) Then Exit For
SheetArray(X, 6) = SheetArray(X, 3)
SheetArray(X, 7) = CDbl(SheetArray(X, 3).ToString) - CDbl(SheetArray(X, 1).ToString) - _
CDbl(SheetArray(X, 7).ToString)
For Y As Integer = 0 To 3
SheetArray(X, Y * 2 + 1) = Math.Round(CDbl(SheetArray(X, Y * 2 + 1).ToString), 3)
Next
If Math.Abs(CDbl(SheetArray(X, 7).ToString)) > 0.1 Then _
.Range(.Cells(X + 1, 1), .Cells(X + 1, 8)).Font.Color = -16776961
Next
I'm getting an error on the first If IsNothing(SheetArray(X, 0)) Then Exit For
line. It is telling me index is out of bounds of the array. Any idea why? The SheetArray object contains the data, but I just am not sure how to get to it.
In the For you have to loop from 0 to Count - 1:
For X As Integer = 0 To SheetArray.GetUpperBound(0) - 1
'...
Next
That will fix your problem.