VBレスキュー(花ちゃん) - VBレスキュー(花ちゃん)の投稿サンプル用掲示板

　　　　　サンプル投稿用掲示板　　 VB2005 ～用トップページ　　 VB6.0 用トップページ

ソート：クイックソート(VB6.0) ( No.4 ) 　[親スレッドへ]

日時： 2011/04/05 11:37
名前： 花ちゃん: ***********************************************************************************
* カテゴリー：[文字列処理][アルゴリズム][]              　　                     *
* キーワード：アルゴリズム,並べ替える,小さい順（昇順）,大きい順（降順）,並び替え　*
***********************************************************************************

【開設当初の掲示板に投稿頂いていた分です】

----------------------------------------------------------------------
ソート：クイックソート　　投稿者：ゆう（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