VBレスキュー(花ちゃん)
VB2005用トップページへVBレスキュー(花ちゃん)のトップページVB6.0用のトップページ各掲示板

リンク元へ戻ります。 数学・算法・基本コード関係のメニュー
１．人に聞けないこんな事(主要プロパティについて)
２．条件判断・条件分け処理関係
３．繰り返し処理関係
４．プログラムの最適化(高速化)について
５．ちょっと便利な小技集
６．10進←→16進相互変換
７．ソート法色々
８．
９．
10．
11．
12．
13．
14．
15．
16．
17．
18．
19．
20．


７．バブルソート シェルソート ヒープソート クイックソート
１．下記ソートプログラムの使用方法
２．バブルソート　 投稿者：ゆう(U) [1998/09/14(月)15：24分]
３．シェルソート　　投稿者：ゆう(U) [1998/09/14(月)15：24分]
４．ヒープソート　　投稿者：ゆう(U) [1998/09/14(月)15：25分]
５．クイックソート　投稿者：ゆう(U) [1998/09/19(土)21：12分]
６．上記プログラムで文字列をソートする場合
７．
８．
９．
　下記プログラムコードに関する補足・注意事項　
動作確認：Windows Vista・Windows 7 (32bit) / VB6.0(SP6)
Option　：[Option Explicit]
参照設定：追加なし
使用 API：なし
その他　：
　　　　：
このページのトップへ移動します。 １．下記ソートプログラムの使用方法

投稿者：ゆう(U)さん

使用方法はすべて同じです。

Dim i As Long
Dim lngArray() As Long
ReDim lngArray(0 To 100) '(-1000 To -1)等のソートもOK

For i = LBound(lngArray) To UBound(lngArray)
lngArray(i) = i
Next i

s????Sort lngArray [, True|, False]

速度を比較すると
低速← sBubleSort > sHeapSort > sShellSort →高速
の順です。
※しかしソートするデータによってはもっと良い(特化)したソート方法が考えられます。
　(一般的なデータではシェルソートが早いみたい)


ヒープソートの添字に負を使用できるようにしている部分をなくすと今より速度が上がると思いますが、良い考えが思い浮かばずこの様なコードになってしまいました(+ lngLowがいっぱいで見栄えが悪い)。

なお、ソートについてはVisualBasicマガジン７月号と河西朝雄著、C言語によるはじめてのアルゴリズム入門(技術評論社)を参考にしました。

※しかし、VBマガジン７月号に掲載されているコードではテストに不十分な為、コードを手直ししないとあまり使えません。
　或るソートでソート後別のソートを試しても配列はソート済みの為、ソート時間が公正では無くなる。

花ちゃん(さん)のヒープソートも試したのですが負の添字もOKなどの仕様で移植しきれなかったので上記アルゴリズム入門を参考にして作成しました。

Long型以外、ユーザー定義型の配列などは前回の投稿を参考にして手直しして使用して下さい。

※この仕様(添字に負を許す)でこのコードより早いソート方法やコードの修正点などをご存知の方(気づかれた方)、その方法　を教えて下さい。
このページのトップへ移動します。 ２．バブルソート　　投稿者：ゆう(U) [1998/09/14(月)15：24分]

前回のバブルソートですがちょっとしたバグが有りました。
(配列の添字が負の数を使用されていると正しい結果を返しません)

と言う訳で添字に負を指定されていても問題なく動作するものをUPします。

'バブルソート(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) [1998/9/14(月)15：24分]

'シェルソート(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) [1998/09/14(月)15：25分]

' ヒープソート(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

　Screen.MousePointer = intMyPointer
End Sub
このページのトップへ移動します。 ５．クイックソート　投稿者：ゆう(U) [1998/09/19(土)21：12分]

' クイックソート(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
　おねがい　
この投稿者の ゆう(U) さんは、このサイトを立ち上げた当時から大変お世話になった方ですが、ある時期(2002/09頃)からネット上で見かけなくなりました。
ずっと気になっているのですが、心当たりのある方は、どうしておられるのか教えて頂けないでしょうか？
たしか、当時は、北海道にお住まいだったような。
このページのトップへ移動します。 ７．



このページのトップへ移動します。 ８．



このページのトップへ移動します。 ９．



このページのトップへ移動します。 検索キーワード及びサンプルコードの別名(機能名)
投稿者：ゆう(U) さん 　バブルソート シェルソート ヒープソート クイックソート　並べ替え　並べ替え　ソート法


このページのトップへ移動します。