いろいろなソート法
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　玄関へお回り下さい。
バブルソート（ゆう（U)さん投稿による）
　　　　 'バブルソート(Long版)
'Sorted(省略可能) = True ：昇順（デフォルト）
' 　　　　 False：降順

Public Sub sBubleSort(ByRef myArray() As Long, _
　　Optional Sorted As Boolean = True)
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Dim intMyPointer As Integer
　　Dim lngLow As Long, lngHigh As Long

　　lngLow = LBound(myArray)
　　lngHigh = UBound(myArray)
　　intMyPointer = Screen.MousePointer
　　 Screen.MousePointer = vbHourglass

　　Select Case Sorted
　　　　Case True 　　'昇順
　　　　For i = lngHigh To lngLow Step -1
　　　　　　For j = lngLow + 1 To i
　　　　　　　　k = j - 1
　　　　　　 　　If myArray(k) > myArray(j) Then
　　　　　　　　　　myArray(j) = myArray(j) Xor myArray(k)
　　　　　　　　　　myArray(k) = myArray(j) Xor myArray(k)
　　　　　　　　　　myArray(j) = myArray(j) Xor myArray(k)
　　　　　　　　End If
　　　　　　Next j
　　　　Next i
　　　　Case Else '降順
　　　　For i = lngHigh To lngLow Step -1
　　　　　　For j = lngLow + 1 To i
　　　　　　　　k = j - 1
　　　　　　　　If myArray(k) < myArray(j) Then
　　　　　　　　　　myArray(j) = myArray(j) Xor myArray(k)
　　　　　　　　　　myArray(k) = myArray(j) Xor myArray(k)
　　　　　　　　　　myArray(j) = myArray(j) Xor myArray(k)
　　　　　　　　End If
　　　　　　　　Next j
　　　　　　Next i
　　　　End Select
　　Screen.MousePointer = intMyPointer
　　 End Sub

　　　　
ヒープソート（ゆう（U)さん投稿による）
　　　　 ' ヒープソート(Long版)
'Sorted(省略可能) = True ：昇順（デフォルト）
' 　　　　 False：降順

Public Sub sHeapSort(ByRef myArray() As Long, _
　　 Optional Sorted As Boolean = True)
　　Dim i As Long, j As Long, k As Long, l As Long, m As Long
　　Dim intMyPointer As Integer
　　Dim lngLow As Long, lngHigh As Long, lngCount As Long
　　Dim tmpArray As Long

　　intMyPointer = Screen.MousePointer
　　Screen.MousePointer = vbHourglass
　　lngLow = LBound(myArray)
　　lngHigh = UBound(myArray)
　　lngCount = lngHigh - lngLow

　　If Sorted Then
　　　　For i = (lngCount \ 2) To i > 0 Step (-1)
　　　　 '共通化可能1
　　　　　　l = i: m = lngCount
　　　　　　k = 2 * l
　　　　　　Do While (k <= m)
　　　　　　If k < m Then
　　　　　　　　If myArray(k + 1 + lngLow) > myArray(k + lngLow) Then
　　　　　　　　　　k = k + 1
　　　　　　　　End If
　　　　　　End If
　　　　　　If myArray(l + lngLow) >= myArray(k + lngLow) Then Exit Do
　　　　　　　　tmpArray = myArray(l + lngLow)
　　　　　　　　myArray(l + lngLow) = myArray(k + lngLow)
　　　　　　　　myArray(k + lngLow) = tmpArray
　　　　　　　　l = k
　　　　　　　　k = 2 * l
　　　　　　Loop
　　　　　　'ここまで
　　　　Next i
　　j = lngCount
　　Do While j > 0
　　tmpArray = myArray(0 + lngLow)
　　myArray(0 + lngLow) = myArray(j + lngLow)
　　myArray(j + lngLow) = tmpArray
　　j = j - 1
　　'共通化可能1
　　l = 0: m = j
　　k = 2 * l
　　Do While (k <= m)
　　　　If k < m Then
　　　　　　If myArray(k + 1 + lngLow) > myArray(k + lngLow) Then
　　　　　　　　 k = k + 1
　　　　　　End If
　　　　End If
　　　　If myArray(l + lngLow) >= myArray(k + lngLow) Then Exit Do
　　　　　　tmpArray = myArray(l + lngLow)
　　　　　　myArray(l + lngLow) = myArray(k + lngLow)
　　　　　　myArray(k + lngLow) = tmpArray
　　　　　　l = k
　　　　　　k = 2 * l
　　Loop
　　'ここまで
　　Loop
　　 Else
　　For i = (lngCount \ 2) To i > 0 Step (-1)
　　　　'共通化可能2
　　　　l = i: m = lngCount
　　　　k = 2 * l
　　Do While (k <= m)
　　　　If k < m Then
　　　　　　If myArray(k + 1 + lngLow) < myArray(k + lngLow) Then
　　　　　　　　k = k + 1
　　　　　　 End If
　　　　End If
　　　　If myArray(l + lngLow) <= myArray(k + lngLow) Then Exit Do
　　　　　　 tmpArray = myArray(l + lngLow)
　　　　　　myArray(l + lngLow) = myArray(k + lngLow)
　　　　　　myArray(k + lngLow) = tmpArray
　　　　　　l = k
　　　　　　k = 2 * l
　　Loop
　　 'ここまで
　　 Next i
　　 j = lngCount
　　 Do While j > 0
　　　　tmpArray = myArray(0 + lngLow)
　　　　myArray(0 + lngLow) = myArray(j + lngLow)
　　　　myArray(j + lngLow) = tmpArray
　　　　j = j - 1
　　　　'共通化可能2
　　　　l = 0: m = j
　　　　k = 2 * l
　　Do While (k <= m)
　　　　If k < m Then
　　　　　　If myArray(k + 1 + lngLow) < myArray(k + lngLow) Then
　　　　　　　　 k = k + 1
　　　　　　End If
　　　　End If
　　　　If myArray(l + lngLow) <= myArray(k + lngLow) Then Exit Do
　　　　　　tmpArray = myArray(l + lngLow)
　　　　　　myArray(l + lngLow) = myArray(k + lngLow)
　　　　　　myArray(k + lngLow) = tmpArray
　　　　　　l = k
　　　　　　k = 2 * l
　　Loop
　　'ここまで
　　Loop
　　 End If
シェルソート（ゆう（U)さん投稿による）
　　　　 'シェルソート(Long版)
'Sorted(省略可能) = True ：昇順（デフォルト）
' 　　　　 False：降順

Public Sub sShellSort(ByRef myArray() As Long, _
　　Optional Sorted As Boolean = True)
　　Dim i As Long, j As Long, k As Long
　　Dim intMyPointer As Integer
　　Dim lngGap As Long
　　Dim lngLow As Long, lngHigh As Long, lngCount As Long
　　Dim tmpArray As Long

　　intMyPointer = Screen.MousePointer
　　 Screen.MousePointer = vbHourglass
　　lngLow = LBound(myArray)
　　lngHigh = UBound(myArray)
　　lngCount = lngHigh - lngLow + 1
　　lngGap = 1

　　 k = Int(lngCount / 3)
　　Do While (lngGap < k)
　　　　lngGap = lngGap * 3 + 1
　　Loop

　　If Sorted Then
　　　　Do While (lngGap > 0)
　　　　　　For i = lngGap + lngLow To lngHigh
　　　　　　　　j = i
　　　　　　　　tmpArray = myArray(j)
　　　　　　　　 Do While j >= lngGap + lngLow
　　　　　　　　　　If myArray(j - lngGap) <= tmpArray Then Exit Do
　　　　　　　　　　 myArray(j) = myArray(j - lngGap)
　　　　　　　　　　j = j - lngGap
　　　　　　　　Loop
　　　　　　　　myArray(j) = tmpArray
　　　　　　Next i
　　　　　　lngGap = Int(lngGap / 3)
　　　　Loop
　　　　Else
　　Do While (lngGap > 0)
　　For i = lngGap + lngLow To lngHigh
　　　　j = i
　　　　tmpArray = myArray(j)
　　　　 Do While j >= lngGap + lngLow
　　　　　　If myArray(j - lngGap) >= tmpArray Then Exit Do
　　　　　　myArray(j) = myArray(j - lngGap)
　　　　　　j = j - lngGap
　　　　Loop
　　 　　myArray(j) = tmpArray
　　Next i
　　lngGap = Int(lngGap / 3)
　　 Loop
　　End If
　　Screen.MousePointer = intMyPointer
End Sub
クイックソート（ゆう（U)さん投稿による）
　　　　 ' クイックソート(Long版)
'Sorted(省略可能) = True ：昇順（デフォルト）
' 　　　　 False：降順

Public Sub sQuickSort(ByRef myArray() As Long, _
　 Optional Sorted As Boolean = True)
　Dim i As Long, j As Long, k As Long, l As Long, m As Long
　Dim intMyPointer As Integer
　Dim lngLow As Long, lngHigh As Long
　Dim tmpArray As Long

　intMyPointer = Screen.MousePointer
　Screen.MousePointer = vbHourglass
　lngLow = LBound(myArray)
　lngHigh = UBound(myArray)

　If Sorted Then
　　　Call sAQuick(myArray(), lngLow, lngHigh)
　Else
　　　Call sDQuick(myArray(), lngLow, lngHigh)
　End If

　Screen.MousePointer = intMyPointer
End Sub

'昇順用Quickソート
Private Sub sAQuick(ByRef myArray() As Long, _
　ByVal lngLeft As Long, _
　ByVal lngRight As Long)
　Dim tmpArray As Long
　Dim i As Long, j As Long

　If lngLeft < lngRight Then
　　　tmpArray = myArray((lngLeft + lngRight) \ 2)
　i = lngLeft
　j = lngRight
　Do While (True)
　　　Do While (myArray(i) < tmpArray)
　　　　　 i = i + 1
　　　Loop
　　　Do While (myArray(j) > tmpArray)
　　　　j = j - 1
　 　　Loop
　　　If i >= j Then Exit Do
　　　myArray(i) = myArray(i) Xor myArray(j)
　　　myArray(j) = myArray(i) Xor myArray(j)
　　　myArray(i) = myArray(i) Xor myArray(j)
　　　i = i + 1
　　　j = j - 1
　Loop
　Call sAQuick(myArray(), lngLeft, i - 1)
　 Call sAQuick(myArray(), j + 1, lngRight)
　End If
End Sub

'降順用Quickソート
Private Sub sDQuick(ByRef myArray() As Long, _
　ByVal lngLeft As Long, _
　ByVal lngRight As Long)
　Dim tmpArray As Long
　Dim i As Long, j As Long

　If lngLeft < lngRight Then
　　　tmpArray = myArray((lngLeft + lngRight) \ 2)
　　　i = lngLeft
　　　j = lngRight
　　　Do While (True)
　　　　　Do While (myArray(i) > tmpArray)
　　　　　　　i = i + 1
　　　　　Loop
　　　　　Do While (myArray(j) < tmpArray)
　　　　　　　 j = j - 1
　　　　　Loop
　　　　　If i >= j Then Exit Do
　　　　　myArray(i) = myArray(i) Xor myArray(j)
　　　　　myArray(j) = myArray(i) Xor myArray(j)
　　　　　myArray(i) = myArray(i) Xor myArray(j)
　　　　　i = i + 1
　　　　　j = j - 1
　　　Loop
　　　Call sDQuick(myArray(), lngLeft, i - 1)
　 　 Call sDQuick(myArray(), j + 1, lngRight)
　 End If
End Sub
このページの内容はゆう（U)さんが掲示板に投稿して頂いた分です。
せっかくの労作、活用させて頂きました。

文字列をソートする場合型宣言をString型にし、一部変更する必要があります。
' myArray(i) = myArray(i) Xor myArray(j)
' myArray(j) = myArray(i) Xor myArray(j)
' myArray(i) = myArray(i) Xor myArray(j)
　　↓
dmy = myArray(j)
myArray(j) = myArray(i)
myArray(i) = dmy
の部分他

又、混在している文字列（カタカナ・漢字等が）をソートする場合文字列の比較の方法を
Option Compare Text　のようにして設定するとエクセル等と同じ並びになります。
省略するとバイナリソートになります

使用例
Dim i As Long
Dim lngArray() As String
ReDim lngArray(Rc1Max) As String 　'(-1000 To -1)等のソートもOK
For i = LBound(lngArray) To UBound(lngArray)
　　Get #1, i + 1, Saco
　　lngArray(i) = Saco.same & " " & Str$(i + 1)
Next i

'sQuickSort lngArray, True
'sHeapSort lngArray, True
sShellSort lngArray, False

List1.Clear
For i = 1 To Rc1Max
　　List1.AddItem lngArray(i)
Next i




01/06/06