I am currently making a highscore table - reading the times from a .csv file and sorting them from lowest to highest. The list only becomes partially sorted after the code runs.
All the data inputs correctly but when it goes to sort it sorts the data out incorrectly.
Private Sub BeginnerProcess(ByRef player() As pe_player, ByVal x As Integer)
Dim i As Integer
Dim j As Integer
Dim temp As Object
For i = x To 0 Step -1
For j = 0 To i - 1
If player(j).playerTime > player(j + 1).playerTime Then
temp = player(j)
player(j) = player(j + 1)
player(j + 1) = temp
End If
Next
Next
Dim k As Integer
For k = 1 To x
player(k).position = k
Next
End Sub
Here's the output
Leaderboard
Adapting the classic bubble-sort to your case, I think i should be something like the code below:
For i = 0 To x - 1
For j = i + 1 To x
If player(i).playerTime > player(j).playerTime Then
temp = player(i)
player(i) = player(j)
player(j) = temp
End If
Next
Next
Related
I have a routing sequence for a set of machines on an assembly line. Each route has to go through the entire line (that is, if you only run the first and second machine, you still account for the distance from the second to the end of the line).
I have six different machines (720 possible combinations of machines) with fixed distances between each location on the line. The distance between the first and second machine is 100', the distance between second and third is 75', third and fourth is 75', fourth and fifth is 25', and fifth and sixth is 25'.
I have 4 different products that have to run down the line, and each of them have a fixed routing.
My problem is, how do I set up a vba code or solver that will allow me to run through all possible combinations of the line setup and determine the optimal setup for this line? Any machine can be placed at any location, as long as it optimizes the result!
The four product routes are :
A - B - C - D - F
A - C - B - D – E - F
A - F - E - D - C - B - A - F
A - C - E - B - D – F
Running through all possible combinations - if you really need to do that - is a job for something like Heap's algorithm, although I prefer the plain changes method:
Sub Evaluate(Lineup() As String)
' dummy evaluation, just output the permutation
Dim OffCell As Long
For OffCell = LBound(Lineup, 1) To UBound(Lineup, 1)
ActiveCell.Offset(0, OffCell).Value = Lineup(OffCell)
Next OffCell
ActiveCell.Offset(1, 0).Activate
End Sub
Sub AllPerms(Lineup() As String)
' Lineup is a 1-D array indexed at 1
Dim LSize As Long
Dim Shift() As Long
Dim Tot As Long
Dim Idx As Long
Dim Level As Long
Dim Change As Long
Dim Offset As Long
Dim TempStr As String
LSize = UBound(Lineup)
ReDim Shift(LSize)
'count of permutations, set initial changes
Tot = 1
For Idx = 2 To LSize
Tot = Tot * Idx
Shift(Idx) = 1 - Idx
Next Idx
Shift(1) = 2 ' end condition
' go through permutations
For Idx = 1 To Tot
' check this one
Call Evaluate(Lineup)
' switch for the next
Level = LSize
Offset = 0
Change = Abs(Shift(Level))
Do While Change = 0 Or Change = Level
If Change = 0 Then Shift(Level) = 1: Offset = Offset + 1
If Change = Level Then Shift(Level) = 1 - Level
Level = Level - 1
Change = Abs(Shift(Level))
Loop
Shift(Level) = Shift(Level) + 1
Change = Change + Offset
TempStr = Lineup(Change)
Lineup(Change) = Lineup(Change + 1)
Lineup(Change + 1) = TempStr
Next Idx
End Sub
Sub ABCDEF_case()
Dim LU(6) As String
LU(1) = "A"
LU(2) = "B"
LU(3) = "C"
LU(4) = "D"
LU(5) = "E"
LU(6) = "F"
Call AllPerms(LU)
End Sub
The well known quicksort routine uses two recursive calls at the end. However, using the quicksort routine in Excel-VBA for large unsorted arrays (> 400 thousand elements) may lead to a memory stack overflow because of the many recursive calls.
Public Sub dQsort(List() As Double, ByVal min As Long, ByVal max As Long)
Dim med_value As Double
Dim hi As Long
Dim lo As Long
Dim i As Long
' If min >= max, the list contains 0 or 1 items so it is sorted.
If min >= max Then GoTo ErrorExit
' Pick the dividing value.
i = (max + min + 1) / 2
med_value = List(i)
' Swap it to the front.
List(i) = List(min)
lo = min
hi = max
Do
' Look down from hi for a value < med_value.
Do While List(hi) >= med_value
hi = hi - 1
If hi <= lo Then Exit Do
Loop
If hi <= lo Then
List(lo) = med_value
Exit Do
End If
' Swap the lo and hi values.
List(lo) = List(hi)
' Look up from lo for a value >= med_value.
lo = lo + 1
Do While List(lo) < med_value
lo = lo + 1
If lo >= hi Then Exit Do
Loop
If lo >= hi Then
lo = hi
List(hi) = med_value
Exit Do
End If
' Swap the lo and hi values.
List(hi) = List(lo)
Loop
' Sort the two sublists.
dQsort List(), min, lo - 1 ' Recursive call which I would like to avoid
dQsort List(), lo + 1, max ' Recursive call which I would like to avoid
End Sub
My question is: Who knows a modified quicksort routine with only a small penalty in extra time compared to the traditional quicksort routine (because of the mentioned memory stack overflow, you can only compare between the "old" and "new" routine for relative small unsorted arrays)?
Answers shown for the "Questions that may already have your answer" are not the answers for my question.
Here is a simple sort for doubles:
Public Sub aSort(ByRef InOut)
Dim i As Long, J As Long, Low As Long
Dim Hi As Long, Temp As Variant
Low = LBound(InOut)
Hi = UBound(InOut)
J = (Hi - Low + 1) \ 2
Do While J > 0
For i = Low To Hi - J
If InOut(i) > InOut(i + J) Then
Temp = InOut(i)
InOut(i) = InOut(i + J)
InOut(i + J) = Temp
End If
Next i
For i = Hi - J To Low Step -1
If InOut(i) > InOut(i + J) Then
Temp = InOut(i)
InOut(i) = InOut(i + J)
InOut(i + J) = Temp
End If
Next i
J = J \ 2
Loop
End Sub
Sub MAIN()
Dim ary(1 To 3) As Double, msg As String
Dim i As Long
ary(1) = 0.4
ary(2) = 0.1
ary(3) = 0.5
Call aSort(ary)
msg = ""
For i = 1 To 3
msg = msg & ary(i) & vbCrLf
Next i
MsgBox msg
End Sub
I don't know if it is "quick" enough.:
The mentioned merge sort has the same disadvantage as the traditional Quicksort: it also uses a recursive call (see the code for Excel’s VBA below, adapted from the named Wiki-page). The TopDownMergeSort sorts only the n-1 array value’s. Therefore, you need to insert the n-th value in the sorted array (of course at the correct place).
Sub Test_Method_MergeSort()
'Array adData with Doubles, starting from index = 1
Call TopDownMergeSort(adData)
Call InsertIntoSortedArray(adData, adData(UBound(adData)), 1, False)
End Sub
'// Array A[] has the items to sort; array B[] is a work array.
Sub TopDownMergeSort(ByRef A() As Double)
Dim B() As Double
Dim n As Long
Dim i As Long
'// duplicate array A[] into B[]
n = UBound(A)
ReDim B(n)
For i = 1 To n
B(i) = A(i)
Next i
'// sort data from B[] into A[]
TopDownSplitMerge B, 1, n, A
End Sub
'Sort the given run of array A[] using array B[] as a source.
'iBegin is inclusive; iEnd is exclusive (A[iEnd] is not in the set).
Sub TopDownSplitMerge(ByRef B() As Double, ByVal iBegin As Long, ByVal iEnd As Long, ByRef A() As Double)
Dim iMiddle As Long
Dim dTmp As Double
If (iEnd - iBegin) < 2 Then Exit Sub ' // if run size == 1
'// split the run longer than 1 item into halves
iMiddle = (iEnd + iBegin) / 2 '// iMiddle = mid point
'// recursively sort both runs from array A[] into B[]
TopDownSplitMerge A, iBegin, iMiddle, B '// sort the left run
TopDownSplitMerge A, iMiddle, iEnd, B '// sort the right run
'// merge the resulting runs from array B[] into A[]
TopDownMerge B, iBegin, iMiddle, iEnd, A
End Sub
'// Left source half is A[ iBegin:iMiddle-1].
'// Right source half is A[iMiddle:iEnd-1].
'// Result is B[ iBegin:iEnd-1].
Sub TopDownMerge(ByRef A() As Double, ByVal iBegin As Long, ByVal iMiddle As Long, ByVal iEnd As Long, ByRef B() As Double)
Dim i As Long
Dim j As Long
Dim k As Long
i = iBegin
j = iMiddle
'// While there are elements in the left or right runs...
For k = iBegin To iEnd - 1
'// If left run head exists and is <= existing right run head.
If ((i < iMiddle) And ((j >= iEnd) Or (A(i) <= A(j)))) Then
B(k) = A(i)
i = i + 1
Else
B(k) = A(j)
j = j + 1
End If
Next k
End Sub
Sub InsertIntoSortedArray(ByRef dSortedArray() As Double, ByVal dNewValue As Double, ByVal LowerBound As Long, Optional ByVal RedimNeeded As Boolean = False) ', xi As Long) As Long
Dim n As Long, ii As Long
n = UBound(dSortedArray)
If RedimNeeded Then
ReDim Preserve dSortedArray(n + 1)
Else
n = n - 1
End If
ii = n + 1
Do Until dSortedArray(ii - 1) <= dNewValue Or ii < (LowerBound + 1)
dSortedArray(ii) = dSortedArray(ii - 1)
ii = ii - 1
Loop
dSortedArray(ii) = dNewValue
End Sub
The solution I was looking for is without any recursive calls. With several additional variables for necessary administration purposes during the sorting steps I succeeded in the following Alternative quicksort “IAMWW_QSort”:
' This code belongs to one and the same Excel’s code module
Private Const msMODULE As String = "M_QSort"
Private alMin() As Long
Private alMax() As Long
Private abTopDownReady() As Boolean
Private aiTopDownIndex() As Integer ' 1 (= TopList) or 2 ( = DownList)
Private alParentIndex() As Long
Sub IAMWW_Qsort(ByRef List() As Double, ByVal Min As Long, ByVal Max As Long)
Dim med_value As Double
Dim hi As Long
Dim lo As Long
Dim i As Long
Dim l_List As Long
' If min >= max, the list contains 0 or 1 items so it is sorted.
If Min >= Max Then GoTo ExitPoint
Call Init(l_List, Min, Max)
Start:
If abTopDownReady(l_List, 1) And abTopDownReady(l_List, 2) Then
abTopDownReady(alParentIndex(l_List), aiTopDownIndex(l_List)) = True
l_List = l_List - 1
If l_List >= 0 Then
GoTo Start
Else
' Ready/list is sorted
GoTo ExitPoint
End If
End If
Min = alMin(l_List)
Max = alMax(l_List)
' -----------------------------------
' The traditional part of QuickSort
' Pick the dividing value.
i = (Max + Min + 1) / 2
med_value = List(i)
' Swap it to the front.
List(i) = List(Min)
lo = Min
hi = Max
Do
' Look down from hi for a value < med_value.
Do While List(hi) >= med_value
hi = hi - 1
If hi <= lo Then Exit Do
Loop
If hi <= lo Then
List(lo) = med_value
Exit Do
End If
' Swap the lo and hi values.
List(lo) = List(hi)
' Look up from lo for a value >= med_value.
lo = lo + 1
Do While List(lo) < med_value
lo = lo + 1
If lo >= hi Then Exit Do
Loop
If lo >= hi Then
lo = hi
List(hi) = med_value
Exit Do
End If
' Swap the lo and hi values.
List(hi) = List(lo)
Loop
' End of the traditional part of QuickSort
' -----------------------------------------
If Max > (lo + 1) Then
' top part as a new sublist
l_List = l_List + 1
Init_NewSubList l_List, l_List - 1, 1, lo + 1, Max
If (lo - 1) > Min Then
' down part as a new sublist
l_List = l_List + 1
Init_NewSubList l_List, l_List - 2, 2, Min, lo - 1
Else
' down part (=2) is sorted/ready
abTopDownReady(l_List - 1, 2) = True
End If
ElseIf (lo - 1) > Min Then
' Top part is sorted/ready...
abTopDownReady(l_List, 1) = True
' ... and down part is a new sublist.
l_List = l_List + 1
Init_NewSubList l_List, l_List - 1, 2, Min, lo - 1
Else
' Both the top (=1) and down part (=2) are sorted/ready ...
abTopDownReady(l_List, 1) = True
abTopDownReady(l_List, 2) = True
' ... and therefore, the parent (sub)list is also sorted/ready ...
abTopDownReady(alParentIndex(l_List), aiTopDownIndex(l_List)) = True
' ... and continue with the before last created new sublist.
l_List = l_List - 1
End If
If l_List >= 0 Then GoTo Start
ExitPoint:
End Sub
Private Sub Init_NewSubList(ByVal Nr As Long, ByVal Nr_Parent As Long, ByVal iTopDownIndex As Integer, ByVal Min As Long, ByVal Max As Long)
' Nr = number of new sublist
' Nr_Parent = the parent's list number of the new sublist
' iTopDownIndex = index for top (=1) or down part (=2) sublist
aiTopDownIndex(Nr) = iTopDownIndex '= 2 ' new sub list is a down part sublist
alParentIndex(Nr) = Nr_Parent 'l_List - 2
abTopDownReady(Nr, 1) = False 'The new sublist has a top part sublist, not ready yet
abTopDownReady(Nr, 2) = False 'The new sublist has a down part sublist, not ready yet
' min and max values of the new sublist
alMin(Nr) = Min
alMax(Nr) = Max 'lo - 1
End Sub
Private Sub Init(ByRef Nr As Long, ByVal Min As Long, ByVal Max As Long)
Dim lArraySize As Long
lArraySize = Max - Min + 1
ReDim alMin(lArraySize)
ReDim alMax(lArraySize)
ReDim abTopDownReady(lArraySize, 2)
ReDim aiTopDownIndex(lArraySize)
ReDim alParentIndex(lArraySize)
Nr = 0
alMin(Nr) = Min
alMax(Nr) = Max
aiTopDownIndex(0) = 2 ' Initial list is assumed to be a down part (= 2)
End Sub
The penalty in extra time because of the additional administrative code lines is very small.
j = LBound(arrayTime)
Do Until j = UBound(arrayTime)
j = j + 1
b = b + 1
cnc = b + r
MsgBox cnc
If cnc > 7 Then
b = 0
r = 0
cnc = b + r
End If
numMins = Sheet5.Cells(cnc + 3, 2) - arrayTime(j)
If numMins < 0 Then
g = g + 1
ReArrangeArray arrayTime, j
'ReDim Preserve arrayTime(numrows - 1 + g)
'arrayTime(numrows - 1 + g) = arrayTime(j)
'MsgBox (arrayTime(numrows - 1 + g))
Else
Sheet5.Cells(cnc + 3, 2) = numMins
End If
Loop
If the if statement is true I want to be able to put the array value at the end of the array and remove that value from its current spot. As the code is, it just adds it to the end and increases the size of the array from 12 to 13. How can I get the array to remain size 12 and still place the value at the end of the array and then remove it from its original position? I do not want to touch the array values in front. Just want to take that value and move it to the end.
For instance
array(1,2,3,4,5)
If statement
j on third loop.
array(j)=3
end array should be
array(1,2,4,5,3)
You could use a helper Sub like this one:
Sub ReArrangeArray(inputArray as Variant, indexToSwap as long)
Dim I As Long
Dim tempVal As Variant
If indexToSwap >= LBound(inputArray) And indexToSwap < UBound(inputArray) Then
tempVal = inputArray(indexToSwap)
For I = indexToSwap To UBound(inputArray) - 1
inputArray(i) = inputArray(i + 1)
Next I
InputArray(UBound(inputArray)) = tempVal
End If
End Sub
To be called by your main Sub as follows:
ReArrangeArray arrayTime, j
the code to generate no. of arrays from one is working..I'm try to make some change to it like below
Function myarray(ByVal arra1() As Integer, ByVal arran() As Integer, ByVal arrNumber As Integer) As Integer()
arran = arra1.Clone()
For i As Integer = 0 To arra1.Length - 1
If i = (arrNumber - 1) Then ' IF arrNumber is 1 then +1 to index 0, If it is 2 then +1 to index 1
arran(i) = arra1(i) + 1
'If there are two duplicate value make on of them zero at a time
For k = 0 To arran.Length - 1
For j = k + 1 To arran.Length - 1
If arran(k) = arran(j) Then
arran(k) = 0
End If
'make any value great than 11 zero
If arran(i) > 11 Then
arran(i) = 0
End If
Next
Next
Else
arran(i) = arra1(i)
End If
Next
'Print the array
For i = 0 To arran.Length - 1
Console.Write(arran(i) & " ")
Next
Console.WriteLine()
Return arran
End Function
what I really need is to decompose for example {1,4,5,5} to be {1,4,0,5} and then {1,4,5,0} the above code generate only {1,4,0,5}
I haven't tested this, but I believe the following code will do what you want. Based on your comments, I've changed the function to return all resulting arrays as an array of arrays, rather than requiring the index to change as an input and returning one array. I also ignored matches of 0, as the conditions you describe don't seem designed to handle them. Because of it's recursion, I think this approach will successfully handle input such as {3, 3, 3, 3}.
Public Function jaggedArray(ByVal inputArray() As Integer) As Integer()()
If inputArray Is Nothing Then
Return Nothing
Else
Dim resultArrays()(), i, j As Integer
Dim arrayMax As Integer = inputArray.GetUpperBound(0)
If arrayMax = 0 Then 'prevents errors later if only one number passed
ReDim resultArrays(0)
If inputArray(0) > 11 Then
resultArrays(0) = {1}
ElseIf inputArray(0) = 11 Then
resultArrays(0) = {0}
Else
resultArrays(0) = {inputArray(0) + 1}
End If
Return resultArrays
End If
For i = 0 To arrayMax
Dim tempArray() As Integer = inputArray.Clone
For j = 0 To arrayMax
If tempArray(j) > 11 Then
tempArray(j) = 0
End If
Next
If tempArray(i) = 11 Then
tempArray(i) = 0
Else
tempArray(i) += 1
End If
splitArray(resultArrays, tempArray)
Next
Return resultArrays
End If
End Function
Private Sub splitArray(ByRef arrayList()() As Integer, ByVal sourceArray() As Integer)
Dim x, y As Integer 'positions of matching numbers
If isValid(sourceArray, x, y) Then
If arrayList Is Nothing Then
ReDim arrayList(0)
Else
ReDim Preserve arrayList(arrayList.Length)
End If
arrayList(arrayList.GetUpperBound(0)) = sourceArray
Else
Dim xArray(), yArray() As Integer
xArray = sourceArray.Clone
xArray(x) = 0
splitArray(arrayList, xArray)
yArray = sourceArray.Clone
yArray(y) = 0
splitArray(arrayList, yArray)
End If
End Sub
Private Function isValid(ByRef testArray() As Integer, ByRef match1 As Integer, ByRef match2 As Integer) As Boolean
For i As Integer = 0 To testArray.GetUpperBound(0) - 1
If testArray(i) > 11 Then
testArray(i) = 0
End If
For j As Integer = i + 1 To testArray.GetUpperBound(0)
If testArray(j) > 11 Then
testArray(j) = 0
End If
If testArray(i) = testArray(j) AndAlso testArray(i) > 0 Then 'added second test to prevent infinite recursion
match1 = i
match2 = j
Return False
End If
Next
Next
match1 = -1
match2 = -1
Return True
End Function
Public Enum eSourceMode
AUS = 0
EIN = 1
End Enum
Public Structure tSourceChannel
Dim OnOff() As eSourceMode
Dim chan_nr As Short
End Structure
I'm trying to set value to
For i = gSources.GetLowerBound(0) To gSources.GetUpperBound(0) Step 1
gSources(i).chan_nr = i
'gSources is 0 based ?
If gSources.GetLowerBound(0) = 0 Then
k = i + 1
Else
k = i
End If
Dim hehe As Integer = gSources.Count
For j = gNoiseBands.GetLowerBound(0) To gNoiseBands.GetUpperBound(0) Step 1
'ab 17.1.2012: gNrSources sets nr of available outputs
If k <= gNrSources Then
gSources(i).OnOff(j) = eSourceMode.EIN
Else
gSources(i).OnOff(j) = eSourceMode.AUS
End If
Next j
Next i
result is exception
System.NullReferenceException occurred
Object reference not set to an instance of an object.
I need this, because I have .ini file and these values :
"gSources0",1,0,1,1,1,1,1
"gSources1",1,1,1,1,1,1,1
"gSources2",1,1,1,1,1,1,1
"gSources3",1,1,1,1,1,1,1
Result of should be for an example :
gSources(0).OnOff(0) = 1 , gSources(0).OnOff(1) = 0
Here you declare that OnOff is an array
Dim OnOff() As eSourceMode
but you never define how large the array should be or assign memory to the array.
'...
Dim hehe As Integer = gSources.Count
'Specify array size
Redim gSources(i).OnOff(gNoiseBands.GetUpperBound(0) - gNoiseBands.GetLowerBound(0))
For j = gNoiseBands.GetLowerBound(0) To gNoiseBands.GetUpperBound(0) Step 1
'...
Next j