1 ''' // ********************************************** 2 ''' // Array Sort Testing 3 4 ''' // (c)digital-ecom GmbH, 2007 5 ''' // Demonstrates why using Shell Sort or Quick Sort Algorythms is superior to Bubble Sort 6 ''' // ********************************************** 7 8 ''' // Main: 9 Sub Sort_Test() 10 Dim WS As Worksheet 11 12 Set WS = ThisWorkbook.Worksheets(2) 13 WS.Activate 14 15 Application.ScreenUpdating = False 16 17 sRange1 = 500 18 sRange2 = 5000 19 sRange3 = 50000 20 21 For i = 1 To 3 22 If i = 1 Then 23 tmpArray = GetArray(sRange1, WS) 24 ElseIf i = 2 Then 25 tmpArray = GetArray(sRange2, WS) 26 Else 27 tmpArray = GetArray(sRange3, WS) 28 End If 29 Call TestSort(tmpArray, WS, i) 30 Next 31 32 Application.ScreenUpdating = True 33 End Sub 34 35 Function GetArray(sRange, WS) 36 Dim i 37 ReDim tmpArray(sRange) 38 39 For i = 4 To sRange 40 tmpArray(i - 4) = WS.Cells(i, 1).Value 41 Next 42 43 GetArray = tmpArray 44 End Function 45 46 47 Sub TestSort(tmpArray, WS, sRange) 48 49 For i = 1 To 3 50 51 If i = 1 And sRange = 1 Then 52 Application.StatusBar = "Bubble Sort 500" 53 ElseIf i = 1 And sRange = 2 Then 54 Application.StatusBar = "Bubble Sort 5000" 55 ElseIf i = 1 And sRange = 3 Then 56 Application.StatusBar = "Bubble Sort 50000" 57 58 ElseIf i = 2 And sRange = 1 Then 59 Application.StatusBar = "Shell Sort 500" 60 ElseIf i = 2 And sRange = 2 Then 61 Application.StatusBar = "Shell Sort 5000" 62 ElseIf i = 2 And sRange = 3 Then 63 Application.StatusBar = "Shell Sort 50000" 64 65 ElseIf i = 3 And sRange = 1 Then 66 Application.StatusBar = "Quick Sort 500" 67 ElseIf i = 3 And sRange = 2 Then 68 Application.StatusBar = "Quick Sort 5000" 69 ElseIf i = 3 And sRange = 3 Then 70 Application.StatusBar = "Quick Sort 50000" 71 Else 72 End If 73 74 If sRange = 1 Then 75 WS.Cells(3 + i, 8).Value = Now 'Starttime 76 ElseIf sRange = 2 Then 77 WS.Cells(3 + i, 11).Value = Now 'Starttime 78 Else 79 WS.Cells(3 + i, 14).Value = Now 'Starttime 80 End If 81 82 If i = 1 Then 83 Call bubblesort(tmpArray) 84 ElseIf i = 2 Then 85 Call ShellSortSingle_Dimension(tmpArray, True) 86 Else 87 Call QuickSort(tmpArray, LBound(tmpArray), UBound(tmpArray)) 88 End If 89 90 If sRange = 1 Then 91 WS.Cells(3 + i, 9).Value = Now 'Endtime 92 ElseIf sRange = 2 Then 93 WS.Cells(3 + i, 12).Value = Now 'Endtime 94 Else 95 WS.Cells(3 + i, 15).Value = Now 'Endtime 96 End If 97 98 Application.ScreenUpdating = True 99 For j = 0 To UBound(tmpArray) 100 If i = 1 Then 101 WS.Cells(j + 4, 3).Value = tmpArray(j) 102 ElseIf i = 2 Then 103 WS.Cells(j + 4, 4).Value = tmpArray(j) 104 Else 105 WS.Cells(j + 4, 5).Value = tmpArray(j) 106 End If 107 Next 108 Application.ScreenUpdating = False 109 110 Next 111 Application.StatusBar = False 112 End Sub 113 114 Function bubblesort(ByRef arrSort As Variant) 115 Dim maxArray As Long 116 117 maxArray = UBound(arrSort) 118 For i = 0 To maxArray 119 For j = i + 1 To maxArray 120 If arrSort(i) > arrSort(j) Then 121 arrTemp = arrSort(i) 122 arrSort(i) = arrSort(j) 123 arrSort(j) = arrTemp 124 End If 125 'Application.StatusBar = "Bubble Sort - Handling element : " & i & " of " & maxArray & " " & j & " of " & maxArray 126 Next 127 Next 128 'bubblesort = arrSortieren 129 End Function 130 131 132 133 Function ShellSortSingle_Dimension(ByRef TMP_Array As Variant, SortAscending As Boolean) 134 Dim i As Long ' Loop Counter 135 Dim j As Long 136 Dim iLBound As Long 137 Dim iUBound As Long 138 Dim iMax As Long 139 Dim iTemp As Variant 140 Dim distance As Long 141 Dim bSortOrder As Variant 142 143 iLBound = LBound(TMP_Array) 144 iUBound = UBound(TMP_Array) 145 146 If SortAscending = True Then 147 bSortOrder = False 148 Else 149 bSortOrder = True 150 End If 151 152 iMax = iUBound - iLBound + 1 153 154 Do 155 distance = distance * 3 + 1 156 Loop Until distance > iMax 157 158 Do 159 distance = distance \ 3 160 For i = distance + iLBound To iUBound 161 iTemp = TMP_Array(i) 162 j = i 163 Do While TMP_Array(j - distance) > iTemp Xor bSortOrder 164 TMP_Array(j) = TMP_Array(j - distance) 165 j = j - distance 166 If j - distance < iLBound Then Exit Do 167 Loop 168 TMP_Array(j) = iTemp 169 Next i 170 Loop Until distance = 1 171 172 'ShellSortSingle_Dimension = TMP_Array 173 End Function 174 175 176 177 Sub QuickSort(vec, loBound, hiBound) 178 Dim pivot, loSwap, hiSwap, temp 179 180 '== This procedure is adapted from the algorithm given in: 181 '== Data Abstractions & Structures using C++ by 182 '== Mark Headington and David Riley, pg. 586 183 '== Quicksort is the fastest array sorting routine for 184 '== unordered arrays. Its big O is n log n 185 186 187 '== Two items to sort 188 If hiBound - loBound = 1 Then 189 If vec(loBound) > vec(hiBound) Then 190 temp = vec(loBound) 191 vec(loBound) = vec(hiBound) 192 vec(hiBound) = temp 193 End If 194 End If 195 196 '== Three or more items to sort 197 pivot = vec(Int((loBound + hiBound) / 2)) 198 vec(Int((loBound + hiBound) / 2)) = vec(loBound) 199 vec(loBound) = pivot 200 loSwap = loBound + 1 201 hiSwap = hiBound 202 203 Do 204 '== Find the right loSwap 205 While loSwap < hiSwap And vec(loSwap) <= pivot 206 loSwap = loSwap + 1 207 Wend 208 '== Find the right hiSwap 209 While vec(hiSwap) > pivot 210 hiSwap = hiSwap - 1 211 Wend 212 '== Swap values if loSwap is less then hiSwap 213 If loSwap < hiSwap Then 214 temp = vec(loSwap) 215 vec(loSwap) = vec(hiSwap) 216 vec(hiSwap) = temp 217 End If 218 Loop While loSwap < hiSwap 219 220 vec(loBound) = vec(hiSwap) 221 vec(hiSwap) = pivot 222 223 '== Recursively call function .. the beauty of Quicksort 224 '== 2 or more items in first section 225 If loBound < (hiSwap - 1) Then Call QuickSort(vec, loBound, hiSwap - 1) 226 '== 2 or more items in second section 227 If hiSwap + 1 < hiBound Then Call QuickSort(vec, hiSwap + 1, hiBound) 228 229 End Sub 'QuickSort 230 231
