>結果。やっぱ再帰のほうが記述が簡単で速い。
ぃゃ、私が書くと..って事なのだが。
>#ぃゃもっと効率良く書けるのかもしれないが..力ないです..orz
とは言うものの、少し足掻いてみた。
>A列に6桁ランダム数値を全角文字列にしたデータでテスト。重複あり。
ちょっとは見通し良くなったけど..ジリキではここが限界?
再帰版の処理順をトレースして作るとこんな感じからどうも抜け出せない...
..っというわけでカンニング編に続く..(ぇ
ぃゃ、私が書くと..って事なのだが。
>#ぃゃもっと効率良く書けるのかもしれないが..力ないです..orz
とは言うものの、少し足掻いてみた。
>A列に6桁ランダム数値を全角文字列にしたデータでテスト。重複あり。
Option Explicit
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private QS() As String 'ソートデータ用
Private QL() As Long 'ソートインデックス用
'-------------------------------------------------
Private Sub test() 'テストプロシージャ選択用
Const cnt As Long = 65536 'テストデータ量
Dim ret() As String '書出し用配列
Dim t(1) As Long
Dim i As Long
Dim v
ReDim QS(1 To cnt)
ReDim QL(1 To cnt)
ReDim ret(1 To cnt, 0)
For Each v In Range("A1").Resize(cnt).Value
i = i + 1
QL(i) = i
QS(i) = v
Next
t(0) = timeGetTime
Call LQuickLoop3
For i = 1 To cnt
ret(i, 0) = QS(QL(i))
Next
t(1) = timeGetTime
'Sheets.Add.Range("A1").Resize(cnt).Value = ret
Erase QS, QL, ret
Debug.Print cnt, t(1) - t(0)
End Sub
'-------------------------------------------------
Private Sub LQuickLoop3() '非再帰
Const p As Long = 100 '記憶用配列サイズ
Dim flg0(p) As Boolean 'Lo処理記憶用
Dim flg1(p) As Boolean 'Up処理記憶用
Dim idxi(p) As Long 'Index記憶用
Dim idxj(p) As Long 'Index記憶用
Dim jj(p) As Long 'Loopカウンタ記憶用
Dim Lv As Long '深さレベル
Dim i As Long
Dim j As Long
Dim k As Long
Dim tmp As String
Lv = 1
idxi(Lv) = LBound(QL)
idxj(Lv) = UBound(QL)
Do While Lv > 0
Do
If flg0(Lv) Then Exit Do
flg0(Lv) = True
i = idxi(Lv)
j = idxj(Lv)
tmp = QS(QL((i + j) ¥ 2))
Do
Do While tmp > QS(QL(i))
i = i + 1
Loop
Do While tmp < QS(QL(j))
j = j - 1
Loop
If i >= j Then
Exit Do
End If
k = QL(i)
QL(i) = QL(j)
QL(j) = k
i = i + 1
j = j - 1
Loop
jj(Lv) = j
If (i - 1) <= idxi(Lv) Then
Exit Do
End If
Lv = Lv + 1
idxi(Lv) = idxi(Lv - 1)
idxj(Lv) = i - 1
flg0(Lv) = False
flg1(Lv) = False
Loop
If Not flg1(Lv) Then
flg1(Lv) = True
If (jj(Lv) + 1) < idxj(Lv) Then
Lv = Lv + 1
idxi(Lv) = jj(Lv - 1) + 1
idxj(Lv) = idxj(Lv - 1)
flg0(Lv) = False
flg1(Lv) = False
Else
Do
Lv = Lv - 1
Loop While flg1(Lv)
End If
End If
Loop
End Sub
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private QS() As String 'ソートデータ用
Private QL() As Long 'ソートインデックス用
'-------------------------------------------------
Private Sub test() 'テストプロシージャ選択用
Const cnt As Long = 65536 'テストデータ量
Dim ret() As String '書出し用配列
Dim t(1) As Long
Dim i As Long
Dim v
ReDim QS(1 To cnt)
ReDim QL(1 To cnt)
ReDim ret(1 To cnt, 0)
For Each v In Range("A1").Resize(cnt).Value
i = i + 1
QL(i) = i
QS(i) = v
Next
t(0) = timeGetTime
Call LQuickLoop3
For i = 1 To cnt
ret(i, 0) = QS(QL(i))
Next
t(1) = timeGetTime
'Sheets.Add.Range("A1").Resize(cnt).Value = ret
Erase QS, QL, ret
Debug.Print cnt, t(1) - t(0)
End Sub
'-------------------------------------------------
Private Sub LQuickLoop3() '非再帰
Const p As Long = 100 '記憶用配列サイズ
Dim flg0(p) As Boolean 'Lo処理記憶用
Dim flg1(p) As Boolean 'Up処理記憶用
Dim idxi(p) As Long 'Index記憶用
Dim idxj(p) As Long 'Index記憶用
Dim jj(p) As Long 'Loopカウンタ記憶用
Dim Lv As Long '深さレベル
Dim i As Long
Dim j As Long
Dim k As Long
Dim tmp As String
Lv = 1
idxi(Lv) = LBound(QL)
idxj(Lv) = UBound(QL)
Do While Lv > 0
Do
If flg0(Lv) Then Exit Do
flg0(Lv) = True
i = idxi(Lv)
j = idxj(Lv)
tmp = QS(QL((i + j) ¥ 2))
Do
Do While tmp > QS(QL(i))
i = i + 1
Loop
Do While tmp < QS(QL(j))
j = j - 1
Loop
If i >= j Then
Exit Do
End If
k = QL(i)
QL(i) = QL(j)
QL(j) = k
i = i + 1
j = j - 1
Loop
jj(Lv) = j
If (i - 1) <= idxi(Lv) Then
Exit Do
End If
Lv = Lv + 1
idxi(Lv) = idxi(Lv - 1)
idxj(Lv) = i - 1
flg0(Lv) = False
flg1(Lv) = False
Loop
If Not flg1(Lv) Then
flg1(Lv) = True
If (jj(Lv) + 1) < idxj(Lv) Then
Lv = Lv + 1
idxi(Lv) = jj(Lv - 1) + 1
idxj(Lv) = idxj(Lv - 1)
flg0(Lv) = False
flg1(Lv) = False
Else
Do
Lv = Lv - 1
Loop While flg1(Lv)
End If
End If
Loop
End Sub
ちょっとは見通し良くなったけど..ジリキではここが限界?
再帰版の処理順をトレースして作るとこんな感じからどうも抜け出せない...
..っというわけでカンニング編に続く..(ぇ