PDA

View Full Version : [SOLVED] Sort Multidimensional Array



realitybend
07-31-2008, 04:03 PM
How do you sort a multidimensional "MyArray(x, 2)" by the first column (I guess you'd call it a column)? All values are numerical.

Kenneth Hobs
07-31-2008, 04:05 PM
An easy method is to join the "columns" by a special character. After the standard bubble sort, split each element to rebuild the array.

Mavyak
07-31-2008, 08:38 PM
You can also make Excel do the sort for you:


Sub TryIt()
Dim MyArray As Variant, x As Integer, y As Integer
MyArray = Selection '<--Comment out this line and replace "MyArray" in the next line with your own two-dimensional
'array or you could select two columns of data and run the code as is.
SortArray MyArray
For x = 1 To UBound(MyArray, 1)
For y = 1 To UBound(MyArray, 2)
Debug.Print MyArray(x, y) & " ";
Next y
Debug.Print
Next x
End Sub

Sub SortArray(ByRef MyArray As Variant)
'Dim MyArray As Variant
Dim w As Worksheet
Dim r As Range
Set w = ThisWorkbook.Worksheets.Add()
'MyArray = Selection
w.Range("A1", w.Range("A1").Offset(UBound(MyArray, 1) - 1, UBound(MyArray, 2) - 1)) = MyArray
Set r = w.Range("A1", w.Range("A1").Offset(UBound(MyArray, 1) - 1, UBound(MyArray, 2) - 1))
r.Sort Key1:=r.Cells(1, 1)
MyArray = r
Set r = Nothing
Application.DisplayAlerts = False
w.Delete
Application.DisplayAlerts = True
Set w = Nothing
End Sub

realitybend
08-01-2008, 11:12 AM
I get a type mismatch here:
w.Range("A1", w.Range("A1").OffSet(UBound(Myarray, 1) - 1, UBound(Myarray, 2) - 1)) = Myarray
I've changed it to an array, like you said, which contains exactly the same data as what I selected when it worked.

What's wrong?

Thanks.

Edit: I changed "MyArray" to "Myarray" on purpose.

Bob Phillips
08-01-2008, 11:49 AM
from the archives http://www.vbaexpress.com/forum/showthread.php?t=12619

Mavyak
08-01-2008, 02:05 PM
I've changed it to an array, like you said, which contains exactly the same data as what I selected when it worked.

What's wrong?

The SortArray function is expecting a variant. I suspect you explicitly declared your array variable as a String. You could Dim a variant variable and store your array in it temporarily to pass it to the SortArray function and then return the contents to your array. Or, you could follow xld's link and bubble-sort it. I only wrote the code above because I hadn't encountered the situation before. I see a puzzle like that sometimes and want to find a way to make it work. The bubble-sort will be less costly overhead-wise since it doesn't create/destroy any objects.

mikerickson
08-02-2008, 07:23 PM
This UDF should do the trick
QSortedArray() takes either a range or an array as its first argument, the second and third arguments (optional) are the columns to sort on. The Decenting determines if the sort is ascending (default) descending.

Option Explicit
Public imageArray As Variant
Public keyCol As Long, keyCol2

Function QSortedArray(ByVal inputRange As Variant, Optional keyColumn As Long, Optional keyColumn2 As Long, Optional Descending As Boolean) As Variant
Dim RowArray As Variant
Dim outRRay As Variant
Dim i As Long, j As Long, size As Long
If keyColumn = 0 Then keyColumn = 1
Rem Input array vs range handeling
On Error GoTo HaltFunction
Select Case TypeName(inputRange)
Case Is = "Range"
If inputRange.Columns.Count < keyColumn Then
QSortedArray = CVErr(xlErrRef): Exit Function
Else
Set inputRange = Application.Intersect(inputRange, inputRange.Parent.UsedRange)
If inputRange Is Nothing Then
QSortedArray = Array(vbNullString): Exit Function
Else
imageArray = inputRange.Value
End If
End If
Case Is = "Variant()", "String()", "Double()", "Long()"
If UBound(inputRange, 2) < keyColumn Then
QSortedArray = Array(CVErr(xlErrRef)): Exit Function
Else
imageArray = inputRange
End If
Case Else
QSortedArray = CVErr(xlErrNA): Exit Function
End Select
On Error GoTo 0
Rem pass arguments To Public variables
If keyColumn2 = 0 Then keyColumn2 = keyColumn
If UBound(imageArray, 2) < keyColumn Then QSortedArray = CVErr(xlErrRef): Exit Function
If UBound(imageArray, 2) < keyColumn2 Then QSortedArray = CVErr(xlErrRef): Exit Function
keyCol = keyColumn
keyCol2 = keyColumn2
Rem create array of row numbers {1,2,3,...,Rows.Count}
size = UBound(imageArray, 1)
ReDim RowArray(1 To size)
For i = 1 To size
RowArray(i) = i
Next i
Rem sort row numbers
Call sortQuickly(RowArray, Descending)
Rem read imageArray With row order per the sorted RowArray
ReDim outRRay(1 To size, 1 To UBound(imageArray, 2))
For i = 1 To size
For j = 1 To UBound(outRRay, 2)
outRRay(i, j) = imageArray(RowArray(i), j)
Next j
Next i
QSortedArray = outRRay
Erase imageArray
HaltFunction:
On Error GoTo 0
End Function

Sub sortQuickly(ByRef inRRay As Variant, Optional ByVal Descending As Boolean, Optional ByVal low As Long, Optional ByVal high As Long)
Dim pivot As Variant
Dim i As Long, pointer As Long
If low = 0 Then low = LBound(inRRay)
If high = 0 Then high = UBound(inRRay)
pointer = low
Call Swap(inRRay, (low + high) / 2, high)
pivot = inRRay(high)
For i = low To high - 1
If LT(inRRay(i), pivot) Xor Descending Then
Call Swap(inRRay, i, pointer)
pointer = pointer + 1
End If
Next i
Call Swap(inRRay, pointer, high)
If low < pointer - 1 Then
Call sortQuickly(inRRay, Descending, low, pointer - 1)
End If
If pointer + 1 <= high Then
Call sortQuickly(inRRay, Descending, pointer + 1, high)
End If
End Sub

Function LT(aRow As Variant, bRow As Variant, Optional Descending As Boolean) As Boolean
On Error GoTo HaltFtn
LT = Descending
If imageArray(aRow, keyCol) = imageArray(bRow, keyCol) Then
LT = imageArray(aRow, keyCol2) < imageArray(bRow, keyCol2)
Else
LT = (imageArray(aRow, keyCol) < imageArray(bRow, keyCol))
End If
HaltFtn:
On Error GoTo 0
End Function

Sub Swap(ByRef inRRay, a As Long, b As Long)
Dim temp As Variant
temp = inRRay(a)
inRRay(a) = inRRay(b)
inRRay(b) = temp
End Sub

realitybend
08-04-2008, 02:45 PM
Thanks! Problem solved.

eamonter
11-23-2016, 05:22 AM
Hi. This is great. I used it and modified so it works with 3 column criteria (one after the other). The problem I have is that with arrays bigger than 500,000 rows it gives me an Out of Stack Space error (Error 28). I've read about it and I understand is related to the RAM use of the heavily recursive method (I only have 4Gb RAM in a 64 Excel 2016). The point is that I need to make this work for roughly 5 million row arrays (5 columns) and sorted by 3 columns criteria. I'm lost in ideas how to make this algorithm a bit slower but less reliant on RAM or if there is any way the variables declarations can be modified so it erases the content the arrays that are not going to be used anymore? Thanks so much!

Paul_Hossler
11-23-2016, 07:24 AM
Welcome

This is a very old post, so it'd be better and you'll get more responses if you start your own with a 'catchy' title

Quick Sort is recursive, and so it can run out of stack space, esp. with a lot of data



Chip Pearson has a module that does the quick sort in place, that MIGHT be better. I've never used it

http://www.cpearson.com/excel/SortingArrays.aspx


http://www.cpearson.com/Zips/modQSortInPlace.zip





Public Function QSortInPlace( _
ByRef InputArray As Variant, _
Optional ByVal LB As Long = -1&, _
Optional ByVal UB As Long = -1&, _
Optional ByVal Descending As Boolean = False, _
Optional ByVal CompareMode As VbCompareMethod = vbTextCompare, _
Optional ByVal NoAlerts As Boolean = False) As Boolean



If the data is on a WS, I'd just use the WS sort, no size limits and it's fast.

If the data is only in a VBA array, I'd copy it to a temp WS, sort it, put it back into the array, and delete the temp WS

mikerickson
11-23-2016, 06:44 PM
Here is a version that doesn't use recursion.
You will have to adjust the getting of the UnsortedArray in test, the output of the SortedArray and (in the function LT), the columns of interest


Dim UnSortedArray As Variant

Sub test()
Dim i As Long, j As Long, temp As Variant
Dim Pivot As Long, PivotPlace As Long
Dim Low As Long, High As Long
Dim Stack() As Long, StackPointer As Long
Dim rowArray() As Long, sortedArray As Variant

Rem get unsorted array, adjust
UnSortedArray = Range("A1:C6").Value


ReDim Stack(1 To 2, 0 To 0)
ReDim rowArray(LBound(UnSortedArray, 1) To UBound(UnSortedArray, 1))
For i = LBound(UnSortedArray, 1) To UBound(UnSortedArray, 1)
rowArray(i) = i
Next i

Low = LBound(rowArray): High = UBound(rowArray)
GoSub Push

Do Until StackPointer <= 0
GoSub Pop

i = (Low + High) / 2
temp = rowArray(i)
rowArray(i) = rowArray(High)
rowArray(High) = temp

Pivot = rowArray(High)
PivotPlace = Low

For i = Low To High - 1
If LT(rowArray(i), Pivot) Then
temp = rowArray(i)
rowArray(i) = rowArray(PivotPlace)
rowArray(PivotPlace) = temp
PivotPlace = PivotPlace + 1
End If
Next i

rowArray(High) = rowArray(PivotPlace)
rowArray(PivotPlace) = Pivot
i = Low: j = High

If Low < PivotPlace Then
High = PivotPlace - 1
GoSub Push
End If

If PivotPlace < j Then
High = j
Low = PivotPlace + 1
GoSub Push
End If
Loop

sortedArray = UnSortedArray
For i = LBound(UnSortedArray, 1) To UBound(UnSortedArray, 1)
For j = LBound(UnSortedArray, 2) To UBound(UnSortedArray, 2)
sortedArray(i, j) = UnSortedArray(rowArray(i), j)
Next j
Next i

Rem adjust output
Range("I1").Resize(UBound(sortedArray, 1), UBound(sortedArray, 2)).Value = sortedArray

Exit Sub
Push:
StackPointer = StackPointer + 1
If UBound(Stack, 2) < StackPointer Then ReDim Preserve Stack(1 To 2, 0 To 2 * StackPointer)
Stack(1, StackPointer) = Low
Stack(2, StackPointer) = High
Return
Pop:
Low = Stack(1, StackPointer)
High = Stack(2, StackPointer)
StackPointer = StackPointer - 1
Return
End Sub

Function LT(a As Long, b As Long) As Boolean
Dim col1 As Long, col2 As Long, col3 As Long
col1 = 1
col2 = 2
col3 = 3

If (UnSortedArray(a, col1) < UnSortedArray(b, col1)) Or (UnSortedArray(a, col1) = vbNullString) Then
LT = True
ElseIf (UnSortedArray(b, col1) < UnSortedArray(a, col1)) Or (UnSortedArray(b, col1) = vbNullString) Then
LT = False
Else
If UnSortedArray(a, col2) < UnSortedArray(b, col2) Then
LT = True
ElseIf UnSortedArray(b, col2) < UnSortedArray(a, col2) Then
LT = False
Else
LT = UnSortedArray(a, col3) < UnSortedArray(a, col3)
End If
End If
End Function

mikerickson
11-23-2016, 10:31 PM
This is a cleaned up version of the above, with a Descending variable that can be set as desired.

Dim UnSortedArray As Variant

Sub test()
Dim i As Long, j As Long, temp As Variant
Dim Pivot As Long, PivotPlace As Long
Dim rowLow As Long, rowHigh As Long
Dim colLow As Long, colHigh As Long
Dim Descending As Boolean
Dim Low As Long, High As Long
Dim Stack() As Long, StackPointer As Long
Dim rowArray() As Long, sortedArray As Variant
Dim Descending As Boolean

Descending = False: Rem set As desired
ReDim Stack(1 To 2, 0 To 0)

Rem get unsorted array, adjust
With Sheet1.Range("A:A")
UnSortedArray = Range(.Cells(Rows.Count, 1).End(xlUp), .Cells(1, 4)).Value
End With

rowLow = LBound(UnSortedArray, 1)
rowHigh = UBound(UnSortedArray, 1)
colLow = LBound(UnSortedArray, 2)
colHigh = UBound(UnSortedArray, 2)

Rem make array of row numbers
ReDim rowArray(rowLow To rowHigh)
For i = rowLow To rowHigh
rowArray(i) = i
Next i

Rem sort array of row numbers ordered by unsortedArray values in LT function

Low = rowLow: High = rowHigh
GoSub Push

Do Until StackPointer <= 0
GoSub Pop

Rem pivot choosing
i = (Low + High) / 2
temp = rowArray(i)
rowArray(i) = rowArray(High)
rowArray(High) = temp


Pivot = rowArray(High)
PivotPlace = Low

For i = Low To High - 1
If LT(rowArray(i), Pivot, Descending) Then
temp = rowArray(i)
rowArray(i) = rowArray(PivotPlace)
rowArray(PivotPlace) = temp
PivotPlace = PivotPlace + 1
End If
Next i

rowArray(High) = rowArray(PivotPlace)
rowArray(PivotPlace) = Pivot
i = Low: j = High

If Low < PivotPlace Then
High = PivotPlace - 1
GoSub Push
End If

If PivotPlace < j Then
High = j
Low = PivotPlace + 1
GoSub Push
End If
Loop

Rem convert sorted array of row numbers into sortedArray
sortedArray = UnSortedArray
For i = rowLow To rowHigh
For j = colLow To colHigh
sortedArray(i, j) = UnSortedArray(rowArray(i), j)
Next j
Next i

Rem adjust output
Range("I1").Resize(rowHigh, colHigh).Value = sortedArray

Exit Sub
Push:
StackPointer = StackPointer + 1
If UBound(Stack, 2) < StackPointer Then ReDim Preserve Stack(1 To 2, 0 To 2 * StackPointer)
Stack(1, StackPointer) = Low
Stack(2, StackPointer) = High
Return
Pop:
Low = Stack(1, StackPointer)
High = Stack(2, StackPointer)
StackPointer = StackPointer - 1
Return
End Sub

Function LT(a As Long, b As Long, Optional Descending As Boolean = False) As Boolean
Dim col1 As Long, col2 As Long, col3 As Long
col1 = 1
col2 = 2
col3 = 3
Rem nullString is GT everything
If UnSortedArray(a, col1) = vbNullString Then
LT = False
ElseIf UnSortedArray(b, col1) = vbNullString Then
LT = True
ElseIf (UnSortedArray(a, col1) < UnSortedArray(b, col1)) Then
LT = True Xor Descending
ElseIf (UnSortedArray(b, col1) < UnSortedArray(a, col1)) Then
LT = False Xor Descending
Else
If UnSortedArray(a, col2) < UnSortedArray(b, col2) Then
LT = True Xor Descending
ElseIf UnSortedArray(b, col2) < UnSortedArray(a, col2) Then
LT = False Xor Descending
Else
LT = (UnSortedArray(a, col3) < UnSortedArray(b, col3)) Xor Descending
End If
End If
End Function

eamonter
11-24-2016, 04:47 AM
Excellent. I'll translate my (5,000,000 x 5) array to the UnSortedArray and see how it goes. I'll let you know. Thanks mikerickson.

eamonter
11-25-2016, 11:48 PM
It worked!. Thanks so much!