Hello There =)
I made a MergeSort function for matrices with Double Data. I haven't found this on the web (one that works, that is), so I'm posting here, so ppl can watch, and maybe improve.
To use with strings and other kinds of variables, you just have to change the compare statement, and the type (Double). The compare statements are bolded.
Cya
Public Function MergeSort(Doubles() As Double) As Double()
Dim s As Long, i As Long, n() As Double, m() As Double
Dim u As Long, l As Long, j As Long, x() As Double
' Only 1 element
If (UBound(Doubles) - LBound(Doubles)) = 0 Then
MergeSort = Doubles
Exit Function
' Only 2 elements
ElseIf (UBound(Doubles) - LBound(Doubles)) = 1 Then
MergeSort = Ordena2(Doubles)
Exit Function
Else
SplitArray Doubles, m, n
m = MergeSort(m)
n = MergeSort(n)
MergeSort = MergeArray(m, n)
End If
End Function
Private Sub SplitArray(Doubles() As Double, _
DoubleOut1() As Double, DoubleOut2() As Double)
Dim meio, pos_Doubles, pos_Quebrado As Long
Dim z As Long
If (UBound(Doubles) - LBound(Doubles)) = 0 Then
Exit Sub
End If
meio = Int((UBound(Doubles) - LBound(Doubles)) / 2)
pos_Quebrado = 0
For pos_Doubles = 0 To (meio - 1)
ReDim Preserve DoubleOut1(pos_Quebrado)
DoubleOut1(pos_Quebrado) = Doubles(pos_Doubles)
pos_Quebrado = pos_Quebrado + 1
Next
pos_Quebrado = 0
For pos_Doubles = meio To UBound(Doubles)
ReDim Preserve DoubleOut2(pos_Quebrado)
DoubleOut2(pos_Quebrado) = Doubles(pos_Doubles)
pos_Quebrado = pos_Quebrado + 1
Next
End Sub
Private Function MergeArray(Double1() As Double, _
Double2() As Double) As Double()
Dim pos1, pos2 As Long
Dim Array_Final() As Double
'Check if Double1 or Double2 are empty
On Error Resume Next
If IsEmpty(Double1(0)) Then
MergeArray = Double2
Exit Function
ElseIf IsEmpty(Double2(0)) Then
MergeArray = Double1
Exit Function
End If
ReDim Array_Final((UBound(Double1) - LBound(Double1) + 1) + (UBound(Double2) - LBound(Double2) + 1) - 1)
pos1 = LBound(Double1)
pos2 = LBound(Double2)
Do Until pos1 > UBound(Double1) Or pos2 > UBound(Double2)
Do While (pos1 <= UBound(Double1) And pos2 <= UBound(Double2))
If Double1(pos1) <= Double2(pos2) Then
Array_Final(pos1 + pos2) = Double1(pos1)
pos1 = pos1 + 1
Else
Exit Do
End If
Loop
Do While (pos1 <= UBound(Double1) And pos2 <= UBound(Double2))
If Double2(pos2) <= Double1(pos1) Then
Array_Final(pos1 + pos2) = Double2(pos2)
pos2 = pos2 + 1
Else
Exit Do
End If
Loop
Loop
'Finaliza o Merge
If pos1 > UBound(Double1) Then
Do Until pos2 > UBound(Double2)
Array_Final(pos1 + pos2) = Double2(pos2)
pos2 = pos2 + 1
Loop
Else ' pos2 > UBound(Double2)
Do Until pos1 > UBound(Double1)
Array_Final(pos1 + pos2) = Double1(pos1)
pos1 = pos1 + 1
Loop
End If
MergeArray = Array_Final
End Function
Public Function Sort2(Doubles() As Double) As Double()
'Comes here when there's only 2 elements to sort
Dim temp As Double
If Doubles(0) > Doubles(1) Then
temp = Doubles(0)
Doubles(0) = Doubles(1)
Doubles(1) = temp
End If
Sort2= Doubles
End Function
MergeSort for Double Arrays
Sameep
Can you post the function Ordena2.
Also a example of how to use the function(s) would be nice ;)
praveench2k
Hehe, sorry, I translated a few parts, and forgot others. =]
To use the MergeSort you just have to pass the vector, like this:
Dim Original_Vector(), Sorted_Vector As Double
Sorted_Vector = MergeSort(Original_Vector)
That way you preserve the original vector, and put the sorted one in another variable. If you want to just sort the vector, do like this:
Original_Vector = MergeSort(Original_Vector)
This was made specially for one-dimension arrays. It won't work for two dimensions or more. This time I deleted some junk, parts of the merges I was trying, before developing my own.
Public Function MergeSort(Doubles() As Double) As Double()
Dim Left() As Double, Right() As Double
' Only 1 element
If (UBound(Doubles) - LBound(Doubles)) = 0 Then
MergeSort = Doubles
Exit Function
' Only 2 elements
ElseIf (UBound(Doubles) - LBound(Doubles)) = 1 Then
MergeSort = Sort2(Doubles)
Exit Function
Else
SplitArray Doubles, Left, Right 'Divide to conquer >:)
m = MergeSort(m) 'Call MergeSort on the small parts of the original vector
n = MergeSort(n) ' same here
MergeSort = MergeArray(m, n) ' At the end, merge the
End If
End Function
Private Sub SplitArray(Doubles() As Double, _
DoubleOut1() As Double, DoubleOut2() As Double)
' Because DoubleOut1 and 2, as well Doubles are passed ByRef, the changes here affect the original ones too.
Dim middle, pos_Doubles, pos_Quebrado As Long
middle= Int((UBound(Doubles) - LBound(Doubles)) / 2)
pos_Quebrado = 0
For pos_Doubles = 0 To (middle - 1)
ReDim Preserve DoubleOut1(pos_Quebrado)
DoubleOut1(pos_Quebrado) = Doubles(pos_Doubles)
pos_Quebrado = pos_Quebrado + 1
Next
pos_Quebrado = 0
For pos_Doubles = middle To UBound(Doubles)
ReDim Preserve DoubleOut2(pos_Quebrado)
DoubleOut2(pos_Quebrado) = Doubles(pos_Doubles)
pos_Quebrado = pos_Quebrado + 1
Next
End Sub
Private Function MergeArray(Double1() As Double, Double2() As Double) As Double()
Dim pos1, pos2 As Long
Dim Array_Final() As Double
'Check if Double1 or Double2 are empty
On Error Resume Next
If IsEmpty(Double1(0)) Then
MergeArray = Double2
Exit Function
ElseIf IsEmpty(Double2(0)) Then
MergeArray = Double1
Exit Function
End If
ReDim Array_Final((UBound(Double1) - LBound(Double1) + 1) + (UBound(Double2) - LBound(Double2) + 1) - 1)
'Set the inicial positions as the lower indexes of Double1 and Double2
pos1 = LBound(Double1)
pos2 = LBound(Double2)
'While the indexes are "inside" the vectors, you search for the lower one
Do Until pos1 > UBound(Double1) Or pos2 > UBound(Double2)
Do While (pos1 <= UBound(Double1) And pos2 <= UBound(Double2))
If Double1(pos1) <= Double2(pos2) Then
Array_Final(pos1 + pos2) = Double1(pos1)
pos1 = pos1 + 1
Else
Exit Do
End If
Loop
Do While (pos1 <= UBound(Double1) And pos2 <= UBound(Double2))
If Double2(pos2) <= Double1(pos1) Then
Array_Final(pos1 + pos2) = Double2(pos2)
pos2 = pos2 + 1
Else
Exit Do
End If
Loop
Loop
'Finish the merge, because one of the vectors didn't go until the end.
If pos1 > UBound(Double1) Then
Do Until pos2 > UBound(Double2)
Array_Final(pos1 + pos2) = Double2(pos2)
pos2 = pos2 + 1
Loop
Else ' pos2 > UBound(Double2)
Do Until pos1 > UBound(Double1)
Array_Final(pos1 + pos2) = Double1(pos1)
pos1 = pos1 + 1
Loop
End If
MergeArray = Array_Final
End Function
Public Function Sort2(Doubles() As Double) As Double()
'Comes here when there's only 2 elements to sort
Dim temp As Double
If Doubles(0) > Doubles(1) Then
temp = Doubles(0)
Doubles(0) = Doubles(1)
Doubles(1) = temp
End If
Sort2= Doubles
End Function
Benedikt
Sub Tester()
Dim Original_Vector() As Double
Dim Sorted_Vector() As Double
Dim lngIndex As Long
Const MAX_ELEMENTS = 50 '
ReDim Original_Vector(MAX_ELEMENTS)
For lngIndex = 1 To MAX_ELEMENTS
Original_Vector(lngIndex) = Rnd() * MAX_ELEMENTS
Next
Sorted_Vector = MergeSort(Original_Vector)
End Sub
Public Function MergeSort(Doubles() As Double) As Double()
Dim Left() As Double, Right() As Double
' Only 1 element
If (UBound(Doubles) - LBound(Doubles)) = 0 Then
MergeSort = Doubles
Exit Function
' Only 2 elements
ElseIf (UBound(Doubles) - LBound(Doubles)) = 1 Then
MergeSort = Sort2(Doubles)
Exit Function
Else
NewSplitArray Doubles, Left, Right 'Divide to conquer >:)
Left = MergeSort(Left) 'Call MergeSort on the small parts of the original vector
Right = MergeSort(Right) ' same here
MergeSort = MergeArray(Left, Right) ' At the end, merge the
End If
End Function
Private Sub NewSplitArray(Doubles() As Double, _
DoubleOut1() As Double, DoubleOut2() As Double)
' Because DoubleOut1 and 2, as well Doubles are passed ByRef, the changes here affect the original ones too.
Dim middle, pos_Doubles, pos_Quebrado As Long
middle = Int((UBound(Doubles) - LBound(Doubles)) / 2)
pos_Quebrado = 0
' Moved out of loop so resize happens only once
ReDim DoubleOut1(middle - 1)
For pos_Doubles = 0 To (middle - 1)
DoubleOut1(pos_Quebrado) = Doubles(pos_Doubles)
pos_Quebrado = pos_Quebrado + 1
Next
pos_Quebrado = 0
ReDim DoubleOut2(UBound(Doubles) - middle)
For pos_Doubles = middle To UBound(Doubles)
DoubleOut2(pos_Quebrado) = Doubles(pos_Doubles)
pos_Quebrado = pos_Quebrado + 1
Next
End Sub
Private Function MergeArray(Double1() As Double, Double2() As Double) As Double()
Dim pos1, pos2 As Long
Dim Array_Final() As Double
'Check if Double1 or Double2 are empty
On Error Resume Next
' Test works on Variants not Double as these will always be FALSE
''' If IsEmpty(Double1(0)) Then
''' MergeArray = Double2
''' Exit Function
''' ElseIf IsEmpty(Double2(0)) Then
''' MergeArray = Double1
''' Exit Function
''' End If
ReDim Array_Final((UBound(Double1) - LBound(Double1) + 1) + (UBound(Double2) - LBound(Double2) + 1) - 1)
'Set the inicial positions as the lower indexes of Double1 and Double2
pos1 = LBound(Double1)
pos2 = LBound(Double2)
'While the indexes are "inside" the vectors, you search for the lower one
Do Until pos1 > UBound(Double1) Or pos2 > UBound(Double2)
Do While (pos1 <= UBound(Double1) And pos2 <= UBound(Double2))
If Double1(pos1) <= Double2(pos2) Then
Array_Final(pos1 + pos2) = Double1(pos1)
pos1 = pos1 + 1
Else
Exit Do
End If
Loop
Do While (pos1 <= UBound(Double1) And pos2 <= UBound(Double2))
If Double2(pos2) <= Double1(pos1) Then
Array_Final(pos1 + pos2) = Double2(pos2)
pos2 = pos2 + 1
Else
Exit Do
End If
Loop
Loop
'Finish the merge, because one of the vectors didn't go until the end.
If pos1 > UBound(Double1) Then
Do Until pos2 > UBound(Double2)
Array_Final(pos1 + pos2) = Double2(pos2)
pos2 = pos2 + 1
Loop
Else ' pos2 > UBound(Double2)
Do Until pos1 > UBound(Double1)
Array_Final(pos1 + pos2) = Double1(pos1)
pos1 = pos1 + 1
Loop
End If
MergeArray = Array_Final
End Function
Public Function Sort2(Doubles() As Double) As Double()
'Comes here when there's only 2 elements to sort
Dim temp As Double
If Doubles(0) > Doubles(1) Then
temp = Doubles(0)
Doubles(0) = Doubles(1)
Doubles(1) = temp
End If
Sort2 = Doubles
End Function