Since function sortArray2D uses some non-built VBA functions, they also must be included in your code for the function to work properly.
Otherwise the following error will occur: Compile error: Sub or Function not defined.
Required functions are listed below. You can get to each function's source code by clicking its name:
When adding the functions above to your VBA project, make sure you haven't done it before. If there are two different public functions with the same name in a single VBA project, the following compilation error is thrown: Compile error: Ambiguous name detected: function_name.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
'**********************************************************************************************************
' Name: sortArray2D
' Author: mielk | 2013-03-13
'
' Comment: Method to sort the given two-dimensional array by the selected column.
'
' Parameters:
' arr Array to be sorted.
' column The index of column by which the given array is to be
' sorted.
' ascending Optional parameter. The order of sorting.
' If this parameter is set to True, the array will be sorted in ascending order.
' Default value of this parameter is True.
' hasHeader s
'
'
' Exceptions:
' NotArrayException Thrown if the given parameter is not an array.
' DimensionsException Thrown if the array passed to this function has less or
' more than 2 dimensions.
' ColumnOutOfRangeException Thrown if the given column by which the array is to be sorted is
' greater than the total number of columns in this array.
'
'
' --- Changes log -----------------------------------------------------------------------------------------
' 2013-03-13 mielk Method created.
'**********************************************************************************************************
Public Sub sortArray2D(arr As Variant, column As Integer, Optional ascending As Boolean = True, _
Optional hasHeader As Boolean = False)
Const METHOD_NAME As String = "sortArray2D"
'------------------------------------------------------------------------------------------------------
Dim orderArray() As Variant
Dim tempArray As Variant
Dim lngRow As Long 'Rows iterator
Dim lngCol As Long 'Columns iterator
Dim lngIndex As Long
Dim bytHeader As Byte: bytHeader = VBA.IIf(hasHeader, 1, 0)
'------------------------------------------------------------------------------------------------------
'Checks if the given parameter [arr] is an array. If not, code --------------------------------------|
'execution moves to the NotArrayException label. '|
If Not isDefinedArray(arr) Then GoTo NotArrayException '|
'----------------------------------------------------------------------------------------------------|
'Only 2-dimensional arrays can be sorted by this function, so check if the array passed -------------|
'as a parameter has exactly two dimensions. If it has less or more dimensions, code execution '|
'moves to the DimensionsException label. '|
If countDimensions(arr) <> 2 Then GoTo DimensionsException '|
'----------------------------------------------------------------------------------------------------|
'Checks if the given column index is in range of this array. ----------------------------------------|
If UBound(arr, 1) < column Or LBound(arr, 1) > column Then GoTo ColumnOutOfRangeException '|
'----------------------------------------------------------------------------------------------------|
'Checks if the given array has more than one item. If there is only one item, -----------------------|
'there is no point to sort it. '|
If UBound(arr, 2) <= (1 + VBA.IIf(hasHeader, 1, 0)) Then GoTo SingleItemArray '|
'----------------------------------------------------------------------------------------------------|
'Creates the temporary array to be used as a map where the index number of the row is the key -------|
'and the value in the specified column of the array is associated to this key. '|
ReDim Preserve orderArray(1 To 2, LBound(arr, 2) + bytHeader To UBound(arr, 2)) '|
For lngRow = LBound(arr, 2) + bytHeader To UBound(arr, 2) '|
orderArray(1, lngRow) = lngRow '|
orderArray(2, lngRow) = arr(column, lngRow) '|
Next lngRow '|
'----------------------------------------------------------------------------------------------------|
'Temporary array is now passed to the subroutine subSortArray2D, where it will be sorted by the -----|
'value from given column. '|
Call subSortArray2D(orderArray, ascending) '|
'----------------------------------------------------------------------------------------------------|
'Create a new array with content of the source array before sorting. --------------------------------|
tempArray = arr '|
'|
'The source array itself is filled from scratch with the values in the proper order (based on '|
'the sorted indices returned in [orderArray]). '|
For lngRow = LBound(arr, 2) + bytHeader To UBound(arr, 2) '|
'|
lngIndex = orderArray(1, lngRow) '|
'|
'--------------------------------------------------------------------------------------------| '|
For lngCol = LBound(arr, 1) To UBound(arr, 1) '| '|
If VBA.IsObject(tempArray(lngCol, lngIndex)) Then '| '|
Set arr(lngCol, lngRow) = tempArray(lngCol, lngIndex) '| '|
Else '| '|
arr(lngCol, lngRow) = tempArray(lngCol, lngIndex) '| '|
End If '| '|
Next lngCol '| '|
'--------------------------------------------------------------------------------------------| '|
'|
Next lngRow '|
'----------------------------------------------------------------------------------------------------|
'==========================================================================================================
ExitPoint:
Exit Sub
'----------------------------------------------------------------------------------------------------------
NotArrayException:
'Error handling for the case when the parameter passed to the function is not an array ...
GoTo ExitPoint
DimensionsException:
'Error handling for the case when the number of dimensions of the array passed to this function
'is different than 2 ...
GoTo ExitPoint
ColumnOutOfRangeException:
'Error handling for the case when the given column index is greater than the total number of
'columns in this array ...
GoTo ExitPoint
SingleItemArray:
'Source array has only one item, so there is no point to sort it. Leave the method without action.
GoTo ExitPoint
End Sub
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
'**********************************************************************************************************
' Name: subSortArray2D
' Author: mielk | 2013-03-13
'
' Comment: Submethod used by sortArray2D method to sort the given map of row indices
' and values.
'
'
' Parameters:
' arr Map Key-Value where the index of the row in the original array is used as a key
' and the value of this row in the specified column is used as a value.
' The map will be sorted by this function in the specified order and used later on
' to populate the result array with the values.
' ascending The order of sorting.
'
'
' --- Changes log -----------------------------------------------------------------------------------------
' 2013-03-13 mielk Method created.
'**********************************************************************************************************
Private Sub subSortArray2D(arr() As Variant, ascending As Boolean)
Const METHOD_NAME As String = "subSortArray2D"
'------------------------------------------------------------------------------------------------------
Dim lowerArr() As Variant 'Subarray with smaller values
Dim higherArr() As Variant 'Subarray with greater values
Dim finalArray() As Variant
Dim lowIndex As Long
Dim highIndex As Long
Dim iRow As Long
Dim iLower As Long
Dim iHigher As Long
'------------------------------------------------------------------------------------------------------
'Check for the bounds of the array. -----------------------------------------------------------------|
lowIndex = LBound(arr, 2) '|
highIndex = UBound(arr, 2) '|
'----------------------------------------------------------------------------------------------------|
'Create two temporary arrays - one dedicated for records with lower values than the base value, -----|
'the other one for higher values. '|
'They are being given the maximum possible size (the same as the size of the original array), '|
'to avoid time-consuming resizing later on. '|
ReDim Preserve lowerArr(1 To 2, 1 To highIndex - lowIndex) '|
ReDim Preserve higherArr(1 To 2, 1 To highIndex - lowIndex) '|
'----------------------------------------------------------------------------------------------------|
'Check if the array has more than 1 item. If it has only one item there is no point to sort it. -----|
If highIndex - lowIndex > 0 Then '|
'|
'Iterate through all the values of the original array and compare them to the first item ----| '|
'in this array. '| '|
'If the value in the second column of the row is lower than the '| '|
'based value, this row is being added to the [lowerArr] array, '| '|
'otherwise it is being added to the [higherArr] array. '| '|
For iRow = lowIndex + 1 To highIndex '| '|
If arr(2, iRow) < arr(2, lowIndex) Then '| '|
iLower = iLower + 1 '| '|
lowerArr(1, iLower) = arr(1, iRow) '| '|
lowerArr(2, iLower) = arr(2, iRow) '| '|
Else '| '|
iHigher = iHigher + 1 '| '|
higherArr(1, iHigher) = arr(1, iRow) '| '|
higherArr(2, iHigher) = arr(2, iRow) '| '|
End If '| '|
Next iRow '| '|
'--------------------------------------------------------------------------------------------| '|
'|
'|
'Resize the [lowerArr] subarray to remove empty slots. --------------------------------------| '|
'Then it is checked how many items it has. If it has more than one '| '|
'this method is called recursively on this subarray. '| '|
If iLower Then '| '|
ReDim Preserve lowerArr(1 To 2, 1 To iLower) '| '|
If iLower > 1 Then Call subSortArray2D(lowerArr, ascending) '| '|
End If '| '|
'--------------------------------------------------------------------------------------------| '|
'|
'The same operations are executed on the [higherArr] subarray. ------------------------------| '| '|
If iHigher Then '| '|
ReDim Preserve higherArr(1 To 2, 1 To iHigher) '| '|
If iHigher > 1 Then Call subSortArray2D(higherArr, ascending) '| '|
End If '| '|
'--------------------------------------------------------------------------------------------| '|
'|
End If '|
'----------------------------------------------------------------------------------------------------|
'Final array is resized to accomodate all the records from the original array. ----------------------|
ReDim Preserve finalArray(1 To 2, lowIndex To highIndex) '|
iRow = lowIndex '|
'----------------------------------------------------------------------------------------------------|
'If the order is set to ascending, the values from the subarray [lowerArr] are added first. ---------|
'Otherwise the values from [higherArr] subarray will be inserted first. '|
If ascending Then '|
Call subSortArray2D_insert(finalArray, lowerArr, iLower, iRow) '|
Else '|
Call subSortArray2D_insert(finalArray, higherArr, iHigher, iRow) '|
End If '|
'----------------------------------------------------------------------------------------------------|
'The based value is inserted in the middle of the final array. --------------------------------------|
finalArray(1, iRow) = arr(1, lowIndex) '|
finalArray(2, iRow) = arr(2, lowIndex) '|
iRow = iRow + 1 '|
'----------------------------------------------------------------------------------------------------|
'Finally, the items from the last subarray ([higherArr] or [lowerArr], depending on the value -------|
'of parameter [ascending]) final array. '|
If ascending Then '|
Call subSortArray2D_insert(finalArray, higherArr, iHigher, iRow) '|
Else '|
Call subSortArray2D_insert(finalArray, lowerArr, iLower, iRow) '|
End If '|
'----------------------------------------------------------------------------------------------------|
'The final array is assigned to variable [arr] and overwrites its current values (in fact the
'values are the same, but their order has changed).
arr = finalArray
End Sub
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
'**********************************************************************************************************
' Name: subSortArray2D_insert
' Author: mielk | 2013-03-13
'
' Comment: Submethod of sortArray2D method to add the given subarray into the final array.
'
'
' Parameters:
' finalArray The reference to the final map Key-Value.
' subarray Sorted subarray.
' index The index of row where the first item of partArray should be added.
' row The index of the row in the final array, where the first item from subarray
' should be inserted.
'
'
' --- Changes log -----------------------------------------------------------------------------------------
' 2013-03-13 mielk Method created.
'**********************************************************************************************************
Private Sub subSortArray2D_insert(finalArray() As Variant, subarray() As Variant, items As Long, _
iRow As Long)
Const METHOD_NAME As String = "subSortArray2D_insert"
'------------------------------------------------------------------------------------------------------
Dim jRow As Long
'------------------------------------------------------------------------------------------------------
'If there are any items in the given subarray ... ---------------------------------------------------|
If items Then '|
'|
'... iterate through them and add them to the final array [arr]. ----------------------------| '|
For jRow = 1 To items '| '|
finalArray(1, iRow) = subarray(1, jRow) '| '|
finalArray(2, iRow) = subarray(2, jRow) '| '|
iRow = iRow + 1 '| '|
Next jRow '| '|
'--------------------------------------------------------------------------------------------| '|
'|
End If '|
'----------------------------------------------------------------------------------------------------|
End Sub