frog.raindrop.jp.knowledge

Option Explicit

Private Const mcstrMODULE_NAME  As String = "CSort" '// モジュール名

Public Sub QSort(plngAry() As Long, ByVal plngStart As Long, ByVal plngEnd As Long)
'============= Declare ==============
Dim lngBasePos      As Long
Dim lngBaseVal      As Long
Dim lngCounter      As Long
Dim lngTemp         As Long
Dim i               As Long

'============= Initiarize ===========
On Error GoTo QSort_E00
    If plngStart >= plngEnd Then Exit Sub
    
'============= Main =================
    
    lngBasePos = (plngStart + plngEnd) \ 2&           '// 中央の要素番号を求める
    lngBaseVal = plngAry(lngBasePos)                '// 中央の値を軸値とする
    
    '// 軸位置に先頭要素を格納
    plngAry(lngBasePos) = plngAry(plngStart)
    lngCounter = plngStart
    
    '// 軸要素より小さければ先頭より詰めていく
    For i = (plngStart + 1&) To plngEnd
        If plngAry(i) < lngBaseVal Then
            lngCounter = lngCounter + 1&
            lngTemp = plngAry(lngCounter)
            plngAry(lngCounter) = plngAry(i)
            plngAry(i) = lngTemp
        End If
    Next i
    
    '// 前詰め最終要素→先頭
    '// 軸要素        →最終位置    (なんかスマートじゃないな)
    plngAry(plngStart) = plngAry(lngCounter)
    plngAry(lngCounter) = lngBaseVal
    
    '// 前詰め最終位置で分けて、再帰呼出
    Call QSort(plngAry, plngStart, lngCounter)
    Call QSort(plngAry, lngCounter + 1&, plngEnd)
    
'============= Release ==============
QSort_L00:
    Exit Sub
'============= Error ================
QSort_E00:
    Call Err.Raise(vbObjectError Or Err.Number, mcstrMODULE_NAME & ".QSort" & "(" & Err.Source & ")", Err.Description, Err.HelpFile, Err.HelpContext)

    Resume QSort_L00
End Sub