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

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

ソート：ヒープソート(VB6.0) ( No.2 ) 　[親スレッドへ]

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

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

----------------------------------------------------------------------
ソート：ヒープソート　　投稿者：ゆう（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