Shakersort & my modifications that don't work :(

[ker_01]

Excel 2003

The function below is a shaker sort, adapted from the website referenced in
the code. I need to make two changes to it;
(1) I'll be feeding this two different arrays and I need to sort them both
the same way (as if it were a 2D array), so I added a second array and
related sorting based on any sorts that occur to the first array, and
(2) I need to have these modifications persist back to the calling
procedure. I thought ByVal would change the "real" array in memory, but if
that doesn't work I need to pass both arrays back to the calling procedure.

So first, using the full sample below, the messagebox is returning the
original array order, not a revised order. I don't know if there is something
wrong with the code, or if ByRef doesn't mean what I think it means?

Second, I tried a few syntax options to have the function return the arrays
as a 1D array of arrays (as a backup, in case I can't just have the changes
persist directly in the original array) but I couldn't get that working
either.

Any advice greatly appreciated!
Keith

Full code sample- just copy/paste into your code module, and run the sub.


Option Base 1

Sub test()

Dim TargetArray(1 To 3) As Long
Dim CategoryArray(1 To 3) As String

TargetArray(1) = 9
TargetArray(2) = 6
TargetArray(3) = 3
CategoryArray(1) = "Zebra"
CategoryArray(2) = "Walrus"
CategoryArray(3) = "Primate"
X = BSortArray(TargetArray, CategoryArray)
End Sub

Private Function BSortArray(ByRef TargetArray() As Long, ByRef
CatagoryArray() As String) As Variant 'will variant allow me to return an
array of arrays automagically?

'Sort multiple parallel 1-D Arrays based on 1-D Shaker Sort
'based on ShakerSort sample from
http://www.xtremevbtalk.com/showthread.php?t=78889
'This is a serious resource on array sorting, and reading it makes my brain
hurt.

'Public Sub ShakerSort(ByRef lngArray() As Long)

Dim iLower As Long
Dim iUpper As Long
Dim iInner As Long
Dim iLBound As Long
Dim iUBound As Long
Dim iTemp As Long
Dim iTemp2 As String
Dim iMax As Long
Dim iMin As Long

iLBound = LBound(TargetArray)
iUBound = UBound(TargetArray)

iLower = iLBound - 1
iUpper = iUBound + 1

Do While iLower < iUpper

iLower = iLower + 1
iUpper = iUpper - 1

iMax = iLower
iMin = iLower

'Find the largest and smallest values in the subarray
For iInner = iLower To iUpper
If TargetArray(iInner) > TargetArray(iMax) Then
iMax = iInner
ElseIf TargetArray(iInner) < TargetArray(iMin) Then
iMin = iInner
End If
Next iInner

'Swap the largest with last slot of the subarray
iTemp = TargetArray(iMax)
TargetArray(iMax) = TargetArray(iUpper)
TargetArray(iUpper) = iTemp
'Then do the exact same thing for the parallel array of category
titles/references
iTemp2 = CatagoryArray(iMax)
CatagoryArray(iMax) = CatagoryArray(iUpper)
CatagoryArray(iUpper) = iTemp2

'Swap the smallest with the first slot of the subarray
iTemp = TargetArray(iMin)
TargetArray(iMin) = TargetArray(iLower)
TargetArray(iLower) = iTemp
'Then do the exact same thing for the parallel array of category
titles/references
iTemp2 = CatagoryArray(iMin)
CatagoryArray(iMin) = CatagoryArray(iLower)
CatagoryArray(iLower) = iTemp2

Loop

'XL doesn't like my attempts to return the function results as an array of
arrays
' BSortArray(1) = TargetArray
' BSortArray(2) = CatagoryArray

'Just verify that the sort itself works
'but it doesn't, the msgbox shows everything in the original order?
MsgBox TargetArray(1) & " " & TargetArray(2) & " " & TargetArray(3) &
Chr(13) & Chr(13) & _
CatagoryArray(1) & " " & CatagoryArray(2) & " " & CatagoryArray(3)

End Function

 

[Bernie Deitrick]

ker,

You picked a bad code source to use as the basis of your code.

If, as in your case, the Max is in the first position and the Min is in the
last, the swapping code blows it by doing the same swap twice, reverting the
data to their original positions. The coder clearly did not check all cases.
The code blows it on other subsequent internal sorts as well.

You can fix the code by checking for that case and only doing the swap once:

'Check if the largest and smallest are in each other's positions
If iMax = iLower And iMin = iUpper Then
iTemp = lngArray(iMax)
lngArray(iMax) = lngArray(iMin)
lngArray(iMin) = iTemp
Else
'Swap the largest with last slot of the subarray
iTemp = lngArray(iMax)
lngArray(iMax) = lngArray(iUpper)
lngArray(iUpper) = iTemp

'Swap the smallest with the first slot of the subarray
iTemp = lngArray(iMin)
lngArray(iMin) = lngArray(iLower)
lngArray(iLower) = iTemp
End If


HTH,
Bernie
MS Excel MVP

 

[Jose Simoes]

Try change:

If lngArray(iInner) > lngArray(iMax) Then
iMax = iInner
ElseIf lngArray(iInner) < lngArray(iMin) Then
iMin = iInner
End If

to

If lngArray(iInner) > lngArray(iMax) Then
iMax = iInner
End If
Else lngArray(iInner) < lngArray(iMin) Then
iMin = iInner
End If

just my $00.02, I had the some problem, it worked for me

Jose Simoes





ker_01 wrote:

Shakersort & my modifications that don't work
01-Dec-09

Excel 200

The function below is a shaker sort, adapted from the website referenced i
the code. I need to make two changes to it
(1) I will be feeding this two different arrays and I need to sort them bot
the same way (as if it were a 2D array), so I added a second array an
related sorting based on any sorts that occur to the first array, an
(2) I need to have these modifications persist back to the callin
procedure. I thought ByVal would change the "real" array in memory, but i
that does not work I need to pass both arrays back to the calling procedure

So first, using the full sample below, the messagebox is returning th
original array order, not a revised order. I do not know if there is somethin
wrong with the code, or if ByRef does not mean what I think it means

Second, I tried a few syntax options to have the function return the array
as a 1D array of arrays (as a backup, in case I cannot just have the change
persist directly in the original array) but I could not get that workin
either

Any advice greatly appreciated
Keit

Full code sample- just copy/paste into your code module, and run the sub

Option Base

Sub test(

Dim TargetArray(1 To 3) As Lon
Dim CategoryArray(1 To 3) As Strin

TargetArray(1) =
TargetArray(2) =
TargetArray(3) =
CategoryArray(1) = "Zebra
CategoryArray(2) = "Walrus
CategoryArray(3) = "Primate
X = BSortArray(TargetArray, CategoryArray
End Su

Private Function BSortArray(ByRef TargetArray() As Long, ByRe
CatagoryArray() As String) As Variant 'will variant allow me to return a
array of arrays automagically

'Sort multiple parallel 1-D Arrays based on 1-D Shaker Sor
'based on ShakerSort sample fro
http://www.xtremevbtalk.com/showthread.php?t=7888
'This is a serious resource on array sorting, and reading it makes my brai
hurt

'Public Sub ShakerSort(ByRef lngArray() As Long

Dim iLower As Lon
Dim iUpper As Lon
Dim iInner As Lon
Dim iLBound As Lon
Dim iUBound As Lon
Dim iTemp As Lon
Dim iTemp2 As Strin
Dim iMax As Lon
Dim iMin As Lon

iLBound = LBound(TargetArray
iUBound = UBound(TargetArray

iLower = iLBound -
iUpper = iUBound +

Do While iLower < iUppe

iLower = iLower +
iUpper = iUpper -

iMax = iLowe
iMin = iLowe

'Find the largest and smallest values in the subarra
For iInner = iLower To iUppe
If TargetArray(iInner) > TargetArray(iMax) The
iMax = iInne
ElseIf TargetArray(iInner) < TargetArray(iMin) The
iMin = iInne
End I
Next iInne

'Swap the largest with last slot of the subarra
iTemp = TargetArray(iMax
TargetArray(iMax) = TargetArray(iUpper
TargetArray(iUpper) = iTem
'Then do the exact same thing for the parallel array of categor
titles/reference
iTemp2 = CatagoryArray(iMax
CatagoryArray(iMax) = CatagoryArray(iUpper
CatagoryArray(iUpper) = iTemp

'Swap the smallest with the first slot of the subarra
iTemp = TargetArray(iMin
TargetArray(iMin) = TargetArray(iLower)

Previous Posts In This Thread:

Shakersort & my modifications that don't work
Excel 200

The function below is a shaker sort, adapted from the website referenced i
the code. I need to make two changes to it
(1) I will be feeding this two different arrays and I need to sort them bot
the same way (as if it were a 2D array), so I added a second array an
related sorting based on any sorts that occur to the first array, an
(2) I need to have these modifications persist back to the callin
procedure. I thought ByVal would change the "real" array in memory, but i
that does not work I need to pass both arrays back to the calling procedure

So first, using the full sample below, the messagebox is returning the
original array order, not a revised order. I do not know if there is something
wrong with the code, or if ByRef does not mean what I think it means?

Second, I tried a few syntax options to have the function return the arrays
as a 1D array of arrays (as a backup, in case I cannot just have the changes
persist directly in the original array) but I could not get that working
either.

Any advice greatly appreciated!
Keith

Full code sample- just copy/paste into your code module, and run the sub.


Option Base 1

Sub test()

Dim TargetArray(1 To 3) As Long
Dim CategoryArray(1 To 3) As String

TargetArray(1) = 9
TargetArray(2) = 6
TargetArray(3) = 3
CategoryArray(1) = "Zebra"
CategoryArray(2) = "Walrus"
CategoryArray(3) = "Primate"
X = BSortArray(TargetArray, CategoryArray)
End Sub

Private Function BSortArray(ByRef TargetArray() As Long, ByRef
CatagoryArray() As String) As Variant 'will variant allow me to return an
array of arrays automagically?

'Sort multiple parallel 1-D Arrays based on 1-D Shaker Sort
'based on ShakerSort sample from
http://www.xtremevbtalk.com/showthread.php?t=78889
'This is a serious resource on array sorting, and reading it makes my brain
hurt.

'Public Sub ShakerSort(ByRef lngArray() As Long)

Dim iLower As Long
Dim iUpper As Long
Dim iInner As Long
Dim iLBound As Long
Dim iUBound As Long
Dim iTemp As Long
Dim iTemp2 As String
Dim iMax As Long
Dim iMin As Long

iLBound = LBound(TargetArray)
iUBound = UBound(TargetArray)

iLower = iLBound - 1
iUpper = iUBound + 1

Do While iLower < iUpper

iLower = iLower + 1
iUpper = iUpper - 1

iMax = iLower
iMin = iLower

'Find the largest and smallest values in the subarray
For iInner = iLower To iUpper
If TargetArray(iInner) > TargetArray(iMax) Then
iMax = iInner
ElseIf TargetArray(iInner) < TargetArray(iMin) Then
iMin = iInner
End If
Next iInner

'Swap the largest with last slot of the subarray
iTemp = TargetArray(iMax)
TargetArray(iMax) = TargetArray(iUpper)
TargetArray(iUpper) = iTemp
'Then do the exact same thing for the parallel array of category
titles/references
iTemp2 = CatagoryArray(iMax)
CatagoryArray(iMax) = CatagoryArray(iUpper)
CatagoryArray(iUpper) = iTemp2

'Swap the smallest with the first slot of the subarray
iTemp = TargetArray(iMin)
TargetArray(iMin) = TargetArray(iLower)

ker,You picked a bad code source to use as the basis of your code.
ker,

You picked a bad code source to use as the basis of your code.

If, as in your case, the Max is in the first position and the Min is in the
last, the swapping code blows it by doing the same swap twice, reverting the
data to their original positions. The coder clearly did not check all cases.
The code blows it on other subsequent internal sorts as well.

You can fix the code by checking for that case and only doing the swap once:

'Check if the largest and smallest are in each other's positions
If iMax = iLower And iMin = iUpper Then
iTemp = lngArray(iMax)
lngArray(iMax) = lngArray(iMin)
lngArray(iMin) = iTemp
Else
'Swap the largest with last slot of the subarray
iTemp = lngArray(iMax)
lngArray(iMax) = lngArray(iUpper)
lngArray(iUpper) = iTemp

'Swap the smallest with the first slot of the subarray
iTemp = lngArray(iMin)
lngArray(iMin) = lngArray(iLower)
lngArray(iLower) = iTemp
End If


HTH,
Bernie
MS Excel MVP


Submitted via EggHeadCafe - Software Developer Portal of Choice
ASP.NET Functionally Rich Repeater Control
http://www.eggheadcafe.com/tutorial...44-8b51c8becd2d/aspnet-functionally-rich.aspx