I have several 3D items in listOri. For this example:
listOri has A,B,C,D,E.
A overlaps with C.
B overlaps with D.
D overlaps with E.
I have a recursive function which accepts listOri, check if each item overlaps with each other, and generates a final listNew which has AC, BDE.
Iteration 1:
Loop through each item in listOri, generates listNew containing AC,B,D,E
Iteration 2:
Loop through AC,B,D,E in listNew, generates (new) listNew containing, AC,BD,E
Iteration 3: and so on.
Here is the snippet code which check if each 3D object in a list overlaps, and produces a new list recursively.
Private Function SimplifyModel2(ByVal listOri As List(Of Mesh3D)) As List(Of Mesh3D)
Dim listNew As New List(Of Mesh3D)(listOri)
Dim indexOut, indexIn, indexInner, PercentProgressCurrent As Integer
Dim currentMeshOutter, currentMeshInner As Mesh3D
Dim isExitForCalled As Boolean = False
totInnerLoops = totInnerLoops + 1 ' increment total number of inner loops
For indexOut = 0 To (listOri.Count - 1)
currentMeshOutter = listOri(indexOut)
indexInner = indexOut + 1
For indexIn = indexInner To (listOri.Count - indexInner)
currentMeshInner = listOri(indexIn)
If Is3DOverlap(currentMeshInner, currentMeshOutter) = True Then
currentMeshOutter.CombineMerge(currentMeshInner)
listNew.Remove(currentMeshInner)
listNew.Remove(currentMeshOutter)
listNew.Insert(0, currentMeshOutter)
listNew = SimplifyModel2(listNew) ' recursively call the function
isExitForCalled = True
Exit For
End If
Next
If isExitForCalled = True Then
Exit For
End If
Next
indLoopExit = indLoopExit + 1
Return listNew
End Function
The function works well with listOri with very few items.
However, when there are thousands of 3D items in listOri, the functions takes very long time to produce the listNew.
How do I increase the speed of the recursive function?
Is there another way to write an algorithm which performs the same task above?
Let me know if you need any information.
Thank you.
I have found the solutions from the Code Review StackExchange.
Please refer to the link below:
Recursive function to merge 3D objects
Related
I think I need to do a loop here but I'm not quite sure how exactly to write out the syntax as I'm used to just using the max function.
The function I need to create takes in two arrays; the first array has the numeric values while the second array has strings. The function is supposed to find the value in the first array that is the largest and return the corresponding string from the second array.
I'm not sure exactly how to construct my loop. I'm thinking I need to use some form of conditional statements.
Here's what I have so far:
Function FindMax(valueArray() As Integer, nameArray() As String) As String
Dim i As Long, y As Long
y = valueArray(0) 'change to 1 if using a different array structure
FindMax = nameArray(0) 'change to 1 if using a different array structure
For i = LBound(valueArray, 1) To UBound(valueArray, 1)
If valueArray(i) > y Then
y = valueArray(i)
FindMax = nameArray(i)
End If
Next i
Debug.Print ; y
Debug.Print ; FindMax
End Function
Here's a worksheet formula that gets the job done quick & easy:
=INDEX($C$3:$C$10,MATCH(MAX($B$3:$B$10),$B$3:$B$10))
If your:
Numbers of which to find the Maximum are in cells B3:B10, and,
Strings that you want to return are in cells C3:C10
...then the Maximum can be found with:
{MyMax} =MAX($B$3:$B$10)
...and the "Position #` of {MyMax} can be found with:
{Pos#} =MATCH( {MyMax} ,$B$3:$B$10)
...and the corresponding string can be found with:
=INDEX($C$3:$C$10, {Pos#} )
...so if we put it all together, we get:
=INDEX($C$3:$C$10,MATCH(MAX($B$3:$B$10),$B$3:$B$10))
Function FindMax(valueArray() As Integer, nameArray() As String) As String
dim i as long, y as long
y = valueArray(0) 'change to 1 if using a different array structure
FindMax = nameArray(0) 'change to 1 if using a different array structure
for i = lbound(valueArray,1) to ubound(valueArray,1)
if valueArray(i) > y then
y = valueArray(i)
FindMax = nameArray(i)
end if
next i
End Function
Pay attention to the bottom half of the code. See where is say :
this=FindMax(arr,arr2)
?
That is how you call a function. Obviously you'll need two arrays to pass to this function. I suggest googling "Functions vba" and do some light reading.
I am creating a poker game - Texas Holdem (5 cards on the table and 2 cards for myself).
I've already created flush, straight and straight flush functions and I got stuck on evaluating if the hand has a:
1. Four of a kind
2. Three of a kind
3. Full house
4. Two pairs
5. One pair
I believe I can write one function for all of the above, that will return a corresponding string.
I have created a list that holds list of Cards (7 cards)
Class Card has a property cardNumber of Integer type (Ace = 1, Two = 2, Three = 3 etc)
Here is my function:
Public Shared Function ofAKind(hand As List(Of Card)) As String
Dim result As String = ""
Dim counter As Integer
Dim IntegerList As New List(Of Integer)
'creating a list of integers that are representing faces of cards
Do
IntegerList.Add(hand.Item(counter).cardNumber)
counter += 1
Loop Until counter = hand.Count
Dim groupedIntegers = From Int In IntegerList
Group By Int
Into grouping = Group, Count()
'and here is my problem: how can I make such a grouping? below is just pseudocode.
'When using a debugger, I see that it groups them well. It is just that I do not know
'how to use LINQ to extract that grouping into the below if statement and get a corresponding string.
'if grouping = 4 Then
'result = "Four of a kind"
'if grouping = 3 andAlso grouping = 2 Then
'result = "Full House"
'if grouping = 2 andAlso grouping = 2 Then
'result = "Two Pairs"
'if grouping = 2 Then
'result = "Pair"
Return result
End Function
For the lack of being able to comment.
Possibly String.Concat all of the card Values together (with whitespace in-between each) and use a Regex.Matches(...) with match code "\d" to match the Numbers
Then Array.ForEach(...) for the Groups() with an in-line If[...] to count the occurrences in each group and test if it has particular combinations of matches.
It may be a little tedious, and a long in-line Linq, but just a thought :p
I figured it out. I am sure it can be done in a cleaner way, but it worked for me. At this phase of my programming discovery - this is a next milestone achieved. Thanks to Plutonix. Appreciate it.
Public Function ofAKind(IntegerList As List(Of Integer)) As String
Dim result As String = "YES"
Dim groupedIntegerList As New List(Of Integer)
Dim groupedIntegers = From Int In IntegerList
Group By Int
Into LOL = Group, Count()
'creating another list (I am sure there is a cleaner way, but I don't know it yet)
For Each e In groupedIntegers
groupedIntegerList.Add(e.Count)
Next
If groupedIntegerList.Contains(3) And groupedIntegerList.Contains(2) Then
result = "Fullhouse!"
ElseIf groupedIntegerList.Contains(4) Then
result = "Four of a kind!"
ElseIf groupedIntegerList.Contains(3) Then
result = "Three of a kind"
ElseIf groupedIntegerList.Contains(2) Then
result = "Pair!"
End If
'ugly way to search for two pairs (but it works)
If result = "Pair!" Then
Dim searchingForTwoPairs = From int In groupedIntegerList
Where int > 1
Group By int
Into LOL2 = Group, Count()
Dim twoPairsList As New List(Of Integer)
For Each e In searchingForTwoPairs
twoPairsList.Add(e.Count)
Next
If twoPairsList.Contains(2) Or twoPairsList.Contains(3) Then
result = "Two pairs!"
End If
End If
Return result
End Function
I have a macro that so far, adds 4 new table columns to an existing table ("Table1"). Now, I would like the macro to format the 3rd and 4th row as percentage. I would like to include this in the loop already listed in my code. I have tried several different ways to do this. I don't think I quite understand how the UBound function works, but hopefully you can understand what I am trying to do.
I also am unsure if I am allowed to continue to utilize the WITH statement in my nested For loop in regards to me 'lst' variable.
#Jeeped - I'm looking at you for this one again...thanks for basically walking me through this whole project lol
Sub attStatPivInsertTableColumns_2()
Dim lst As ListObject
Dim currentSht As Worksheet
Dim colNames As Variant, r1c1s As Variant
Dim h As Integer, i As Integer
Set currentSht = ActiveWorkbook.Sheets("Sheet1")
Set lst = ActiveSheet.ListObjects("Table1")
colNames = Array("AHT", "Target AHT", "Transfers", "Target Transfers")
r1c1s = Array("=([#[Inbound Talk Time (Seconds)]]+[#[Inbound Hold Time (Seconds)]]+[#[Inbound Wrap Time (Seconds)]])/[#[Calls Handled]]", "=350", "=[#[Call Transfers and/or Conferences]]/[#[Calls Handled]]", "=0.15")
With lst
For h = LBound(colNames) To UBound(r1c1s)
.ListColumns.Add
.ListColumns(.ListColumns.Count).Name = colNames(h)
.ListColumns(.ListColumns.Count).DataBodyRange.FormulaR1C1 = r1c1s(h)
If UBound(colNames(h)) = 2 or UBound(colNames(h)) = 3 Then
For i = UBound(colNames(h), 2) To UBound(colNames(h), 3)
.ListColumns(.ListColumns.Count).NumberFormat = "0%"
End if
Next i
Next h
End With
End Sub
You don't need to nest a second for loop. If you want to set the 3rd and 4th columns to a percentage, you only need to set that when the iteration of the loop (h) is 2 or 3 (remembering that arrays index from 0). You also shouldn't cross arrays for the main loop, and since LBound is in most cases 0 you might as well just use that anyway. Try this:
With lst
For h = 0 To UBound(r1c1s)
.ListColumns.Add
.ListColumns(.ListColumns.Count).Name = colNames(h)
.ListColumns(.ListColumns.Count).DataBodyRange.FormulaR1C1 = r1c1s(h)
If h = 2 or h = 3 Then
.ListColumns(.ListColumns.Count).NumberFormat = "0%"
End if
Next h
End With
To answer the other point in your question, UBound(array) just gives the index of the largest element (the Upper BOUNDary) in the given array. So where you have 50 elements in such an array, UBound(array) will return 49 (zero based as mentioned before). LBound just gives the other end of the array (the Lower BOUNDary), which is generally zero.
I'm trying to teach myself some basic VBA in Excel 2010 and I've come across a problem I can't google myself out of. The objective is to create a button which when pressed, automatically does linest for me and writes the values into an array. So far, this is my code.
Private Sub CommandButton1_Click()
Dim linest As Variant
Dim linestArray(4,1) as Variant
Dim i As Integer, j as Integer
linest = Application.LinEst(Range("U49:U51"), Range("T49:T51"), True, True)
For i = 0 To 4
linestArray(i,0) = accessing values of linest variable fyrst column
Cells(68 + i, 21) = linestArray(i,0)
Next
For j = 0 To 4
linestArray(j,1) = accessing values of linest variable second column
Cells(68 + j, 22) = linestArray(j,0)
Next
End Sub
How do I access the values of variable linest so I can store them to an array and print them? Thank you.
EDIT: I figured it out. Variable linest is already an array! I feel pretty dumb. Sorry, this can be ignored.
New code:
Dim linestArray As Variant
linestArray = Application.LinEst(Range("U49:U51"), Range("T49:T51"), True, True)
For i = 0 To 4
For j = 0 To 1
Cells(68 + i, 21 + j) = linestArray(i + 1, j + 1)
Next
Next
The output of any such formula is a Variant array. So you've got that part right.
For a general approach to these Application. (use WorksheetFunction. instead, it's much faster) type functions is...
Type the function in Excel (as an array formula, Ctrl-Shift-Return, if need be)
The output is an N x M matrix of some sort (N =1 , M =1) for most cases
When you do Var = Application.Linest(xyx), the answer gets stored in Var
Get the size of the Var using Ubound(Var, 1), Ubound(Var, 2) to get number of rows and columns (note that these are base 0 type arrays)
Usually, the size will be one x one. In that case, your variable is stored in Var(0,0) i.e. a zero base multidimensional variant array, the top left element.
Hope this helps.
I've been looking for solution of one mathematical problem
I have fix set of numbers
[65536, 131072, 262144, 524288, 104576, 2097152]
I will have some total of above numbers only
but my problem is how I can get a combination of numbers in given total?
Please help me plz
My solution is very similar to Davids.
Assumption: The set of numbers is ordered ascending.
Call the function and start with the highest number, pass an empty partial solution and try to calculate all possible sums of the set of numbers that return total. The sums are returned as a Collection.
The function:
create a list to hold all solutions
Test for each number in the set (starting with the passed numberSetIndex and move down):
if number > total then skip to the next number
append the number to the partial solution
if number = total then add this partial solution to the list and move on to the next number
if number < total then
call this function again (with total -= number and a copy of the partial solution, and with the current index of the number)
append all returned solutions
return all solutions
Watch out: I did not understand if you wanted to use each number of the set only once for the sum, so the code below will also calculate sums that contain more than one instance of a number in the given set.
If you want each number to appear only once, locate the line
Set result = AllSumsForTotalFromSet(total - number, numberSet, index, CopyAndReDimPlus1(partialSolution))
in the function Function AllSumsForTotalFromSet and replace index with index-1 in the recursive call.
Sub Test_AllSumsForTotalFromSet()
Dim numberSet, total As Long, result As Collection
numberSet = Array(65536, 131072, 262144, 524288, 104576, 2097152)
total = 366720
Set result = GetAllSumsForTotalFromSet(total, numberSet)
Debug.Print "Possible sums: " & result.count
PrintResult result
End Sub
Function GetAllSumsForTotalFromSet(total As Long, ByRef numberSet As Variant) As Collection
Set GetAllSumsForTotalFromSet = New Collection
Dim partialSolution(1 To 1) As Long
Set GetAllSumsForTotalFromSet = AllSumsForTotalFromSet(total, numberSet, UBound(numberSet), partialSolution)
End Function
Function AllSumsForTotalFromSet(total As Long, ByRef numberSet As Variant, numberSetIndex As Long, ByRef partialSolution() As Long) As Collection
Dim index As Long, number As Long, result As Collection
Set AllSumsForTotalFromSet = New Collection
'break if numberSetIndex is too small
If numberSetIndex < LBound(numberSet) Then Exit Function
For index = numberSetIndex To LBound(numberSet) Step -1
number = numberSet(index)
If number <= total Then
'append the number to the partial solution
partialSolution(UBound(partialSolution)) = number
If number = total Then
AllSumsForTotalFromSet.Add partialSolution
Else
Set result = AllSumsForTotalFromSet(total - number, numberSet, index, CopyAndReDimPlus1(partialSolution))
AppendCollection AllSumsForTotalFromSet, result
End If
End If
Next index
End Function
'copy the passed array and increase the copy's size by 1
Function CopyAndReDimPlus1(ByVal sourceArray As Variant) As Long()
Dim i As Long, destArray() As Long
ReDim destArray(LBound(sourceArray) To UBound(sourceArray) + 1)
For i = LBound(sourceArray) To UBound(sourceArray)
destArray(i) = sourceArray(i)
Next i
CopyAndReDimPlus1 = destArray
End Function
'append sourceCollection to destCollection
Sub AppendCollection(ByRef destCollection As Collection, ByRef sourceCollection As Collection)
Dim e
For Each e In sourceCollection
destCollection.Add e
Next e
End Sub
Sub PrintResult(ByRef result As Collection)
Dim r, a
For Each r In result
For Each a In r
Debug.Print a;
Next
Debug.Print
Next
End Sub
Interesting thought experiment... here is my solution (pre-warning - no code, only algorithm)
Order the list descending
Use a tree/node structure
Write a recursive loop that traverses the list. If the value that it is at is less than the remaining value, add that value as a child
If the value that it is at is equal to the remaining total, add that value as a child and mark as a solution
if the value that it is at is greater than the remaining total, mark the branch as not solvable
IF the end of the list is reached, mark that branch as not solvable
You should end up with a tree representing the valid solutions. Example:
set = [50,40,30,20,15,10,5]
total required = 60
Solution tree
root
50 -> 10
40 -> 20
-> 15 -> 5
30 -> 20 -> 10
-> 15 -> 10 -> 5