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>