VBA/Excel/Access/Word/Data Type/Array Sort
Содержание
Performing a Binary Search through an Array
<source lang="vb"> Option Explicit Option Base 1 Sub Binary_Search_of_Array() Dim intThousand(1000) As Integer Dim i As Integer Dim intTop As Integer Dim intMiddle As Integer Dim intBottom As Integer Dim varUserNumber As Variant For i = 1 To 1000 intThousand(i) = i Next i varUserNumber = 233 intTop = UBound(intThousand) intBottom = LBound(intThousand) Do intMiddle = (intTop + intBottom) / 2 If varUserNumber > intThousand(intMiddle) Then intBottom = intMiddle + 1 Else intTop = intMiddle - 1 End If Loop Until (varUserNumber = intThousand(intMiddle)) _ Or (intBottom > intTop) If varUserNumber = intThousand(intMiddle) Then Debug.Print varUserNumber & ", at position " & intMiddle Else Debug.Print "not in " End If End Sub </source>
Quick sort
<source lang="vb">
Private Sub QuickSort(ByRef Values As Variant, Optional ByVal Left As Long, Optional ByVal Right As Long)
Dim I As Long Dim J As Long Dim K As Long Dim Item1 As Variant Dim Item2 As Variant On Error GoTo Catch If IsMissing(Left) Or Left = 0 Then Left = LBound(Values) If IsMissing(Right) Or Right = 0 Then Right = UBound(Values) I = Left J = Right Item1 = Values((Left + Right) \ 2, 2) Do While I < J Do While Values(I, 2) < Item1 And I < Right I = I + 1 Loop Do While Values(J, 2) > Item1 And J > Left J = J - 1 Loop If I < J Then Call Swap(Values, I, J) End If If I <= J Then I = I + 1 J = J - 1 End If Loop If J > Left Then Call QuickSort(Values, Left, J) If I < Right Then Call QuickSort(Values, I, Right) Exit Sub
Catch:
MsgBox Err.Description, vbCritical
End Sub Private Sub Swap(ByRef Values As Variant, ByVal I As Long, ByVal J As Long)
Dim Temp1 As Double Dim Temp2 As Double Temp1 = Values(I, 1) Temp2 = Values(I, 2) Values(I, 1) = Values(J, 1) Values(I, 2) = Values(J, 2) Values(J, 1) = Temp1 Values(J, 2) = Temp2
End Sub
</source>
Quick Sort 2
<source lang="vb">
Sub Main()
Dim myArray(4) As Double myArray(0) = 9 myArray(1) = 11 myArray(2) = 7 myArray(3) = 4 Call QSort(myArray, 0, 4) Debug.Print myArray(0) Debug.Print myArray(1) Debug.Print myArray(2) Debug.Print myArray(3)
End Sub Sub QSort(sortArray() As Double, ByVal leftIndex As Integer, _
ByVal rightIndex As Integer) Dim compValue As Double Dim I As Integer Dim J As Integer Dim tempNum As Double I = leftIndex J = rightIndex compValue = sortArray(Int((I + J) / 2)) Do Do While (sortArray(I) < compValue And I < rightIndex) I = I + 1 Loop Do While (compValue < sortArray(J) And J > leftIndex) J = J - 1 Loop If I <= J Then tempNum = sortArray(I) sortArray(I) = sortArray(J) sortArray(J) = tempNum I = I + 1 J = J - 1 End If Loop While I <= J If leftIndex < J Then QSort sortArray(), leftIndex, J If I < rightIndex Then QSort sortArray(), I, rightIndex
End Sub
</source>
using dynamic arrays in bubble sort
<source lang="vb">
Public Sub DynamicBubble()
Dim tempVar As Integer Dim anotherIteration As Boolean Dim I As Integer Dim arraySize As Integer Dim myArray() As Integer Do arraySize = I I = I + 1 Loop Until Cells(I, "A").Value = "" ReDim myArray(arraySize - 1) For I = 1 To arraySize myArray(I - 1) = Cells(I, "A").Value Next I Do anotherIteration = False For I = 0 To arraySize - 2 If myArray(I) > myArray(I + 1) Then tempVar = myArray(I) myArray(I) = myArray(I + 1) myArray(I + 1) = tempVar anotherIteration = True End If Next I Loop While anotherIteration = True " For I = 1 To arraySize Cells(I, "B").Value = myArray(I - 1) Next I
End Sub
</source>
VBA Bubble Sort
<source lang="vb">
Public Sub BubbleSort()
Dim tempVar As Integer Dim anotherIteration As Boolean Dim I As Integer Dim iterationNum As Integer Dim sortArray(10) As Integer For I = 2 To 11 sortArray(I - 2) = Cells(I, "A").Value Next I Do anotherIteration = False For I = 0 To 8 If sortArray(I) > sortArray(I + 1) Then tempVar = sortArray(I) sortArray(I) = sortArray(I + 1) sortArray(I + 1) = tempVar anotherIteration = True End If Next I iterationNum = iterationNum + 1 Cells(1, iterationNum + 2).Value = iterationNum For I = 0 To 9 Cells(I + 2, iterationNum + 2).Value = sortArray(I) Next I Loop While anotherIteration = True
End Sub
</source>