VBScript 複数キーでソート（クイックソート）
VBScriptクイックソートのソースCOPY元
「VBScript でソートする (unibon)」様
http://www.geocities.co.jp/SiliconValley/4334/unibon/asp/vbscriptsort.html
更新しようとしたらぶっ壊れました。
再編集しようとすると HTMLかgooブログの仕様みたいで、"<" ">" がうまく入りません。
「＜」multi を 「<」singleに置き換えてください。
「＞」multi を 「>」singleに置き換えてください。
＆ｌｔ； と ＆ｇｔ； でエスケープしてみたが、
＆ｇｔ；（＞）は、うまくいくが、＆ｌｔ；（＜)の
とある部分から、全部イタリックに変わる現象発生のため。
'＜クイックsort.vbs＞
'「＜」multi を 「<」singleに置き換えてください。
'「＞」multi を 「>」singleに置き換えてください。
Option Explicit
MsgBox "処理開始"
Dim key_num
Dim key_idx(9)
Dim key_dir(9)
Dim key_typ(9)
key_num = 3 'keyの個数
ReDim sortKEY(key_num)
'key001
key_idx(0) = 0 'キーのカラム番号
key_dir(0) = 0 '0:昇順 1:降順
key_typ(0) = 0 '0:文字 1:数字
'key002
key_idx(1) = 1 'キーのカラム番号
key_dir(1) = 1 '0:昇順 1:降順
key_typ(1) = 0 '0:文字 1:数字
'key003
key_idx(2) = 4 'キーのカラム番号
key_dir(2) = 1 '0:昇順 1:降順
key_typ(2) = 1 '0:文字 1:数字
Dim strPathIn
Dim strPathOut
Dim oFS
Dim oFR
Dim oFW
Dim oDic1
Set oDic1 = CreateObject("Scripting.Dictionary")
Dim oDic2
Set oDic2 = CreateObject("Scripting.Dictionary")
Dim myDATA
Dim myCSV
Dim myItems
Dim i
Dim j
Dim iMax
Dim iMin
Dim chgWK
const ForReading = 1,ForWriting = 2,ForAppending = 8
strPathIn = "TEST_IN65536.dat"
'strPathIn = "TEST_IN6000_2.dat"
strPathOut = "test_IN65536_クイックout.txt"
Set oFS = CreateObject("Scripting.FileSystemObject")
If oFS.fileExists(strPathIn) Then
Set oFR = oFS.OpenTextFile(strPathIn, ForReading)
Set oFW = oFS.OpenTextFile(strPathOut, ForWriting, True)
i = 0
Do While Not oFR.AtEndOfStream
myDATA = oFR.ReadLine
oDic1.Add i, myDATA
myCSV = Split(myDATA,",")
For j = 0 To key_num - 1
sortKEY(j) = myCSV(key_idx(j))
Next
sortKEY(key_num) = i
oDic2.ADD i, sortKEY
i = i + 1
Loop
iMax = i - 1
oFR.Close
Set oFR = Nothing
myItems = oDic2.Items
MsgBox "キー作成完了。ソートします。"
'クイックソート
If 0 ＜ UBound(myItems) Then
Call sortQuickSub(myItems, 0, UBound(myItems))
End If
MsgBox "ソート完了。出力します。"
For i = 0 To iMax
oFW.WriteLine oDic1.Item(myItems(i)(key_num))
Next
oFW.Close
Set oFW = Nothing
Else
Call MsgBox("ファイルが見つかりません！",48,"エラー")
End If
Set oFS = Nothing
Set oDic1 = Nothing
Set oDic2 = Nothing
MsgBox "処理終了"
Sub sortQuickSub(ByRef a, ByVal p, ByVal q) ' クイックソート(内部ルーチン)
Dim a001
Dim b001
Dim chgwk
Dim i
i = p
Dim j
j = q
Dim x
x = a(p)
Do
'Do While a(i) ＜ x
Do While func_compare(a(i), x)
i = i + 1
Loop
'Do While x ＜ a(j)
Do While func_compare(x, a(j))
j = j - 1
Loop
If i ＞= j Then
Exit Do
End If
'Call swap(a(i), a(j))
chgwk = a(i)
a(i) = a(j)
a(j) = chgwk
i = i + 1
j = j - 1
Loop
If p ＜ i - 1 Then
Call sortQuickSub(a, p, i - 1)
End If
If j + 1 ＜ q Then
Call sortQuickSub(a, j + 1, q)
End If
End Sub
Function func_compare(a01,b01)
Dim k
For k = 0 To key_num - 1
If key_typ(k) = 1 Then
If key_dir(k) = 1 Then
If CDbl(a01(k)) ＞ CDbl(b01(k)) Then
func_compare = True : Exit Function
End If
If CDbl(a01(k)) ＜ CDbl(b01(k)) Then
func_compare = False : Exit Function
End If
Else
If CDbl(a01(k)) ＜ CDbl(b01(k)) Then
func_compare = True : Exit Function
End If
If CDbl(a01(k)) ＞ CDbl(b01(k)) Then
func_compare = False : Exit Function
End If
End If
Else
If key_dir(k) = 1 Then
If CStr(a01(k)) ＞ CStr(b01(k)) Then
func_compare = True : Exit Function
End If
If CStr(a01(k)) ＜ CStr(b01(k)) Then
func_compare = False : Exit Function
End If
Else
If CStr(a01(k)) ＜ CStr(b01(k)) Then
func_compare = True : Exit Function
End If
If CStr(a01(k)) ＞ CStr(b01(k)) Then
func_compare = False : Exit Function
End If
End If
End If
Next
If Clng(a01(key_num)) ＜ Clng(b01(key_num)) Then
func_compare = True
Else
func_compare = False
End If
End Function
＜csv_seed.vbs＞
'「CSV種.vbs」
Option Explicit
Const ForReading = 1
Const ForWriting = 2
Const ForAppeding = 8
Dim strPathIn
Dim strPathOut
Dim oFS
Dim oFW
Dim i
Dim work(4)
Dim j
Dim signA(2)
strPathOut = "TEST_IN65536.dat"
Set oFS = CreateObject("Scripting.FileSystemObject")
Set oFW = oFS.OpenTextFile(strPathOut,ForWriting,True)
Randomize
For i = 1 To 65536
work(0) = Chr(Int(Rnd()*7 + 65)) & Chr(Int(Rnd()*7 + 65))
work(1) = Chr(Int(90-Int(Rnd()*3)))
For j = 0 To 2
If Int(Rnd()*2) = 1 Then
signA(j) = "-"
Else
SignA(j) = ""
End If
Next
work(2) = SignA(0) & _
(Int(Rnd()* 10000000000000))
work(3) = SignA(1) & _
(Int(Rnd()* 10000000000000))
work(4) = SignA(2) & _
(Int(Rnd()* 10000000000000))
oFW.WriteLine Join(work,",")
Next
oFW.Close
Set oFW = Nothing
Set oFS = Nothing
Wscript.Echo "処理終了"
＜check_result.vbs＞
Option Explicit
Dim INFILE:INFILE = "test_IN65536_クイックout.txt"
Dim OTFILE:OTFILE = "Check_result.txt"
Dim oFS
Dim oFR
Dim oFW
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
Set oFS = CreateObject("Scripting.FileSystemObject")
Set oFR = oFS.OpenTextFile(INFILE, ForReading)
Set oFW = oFS.OpenTextFile(OTFILE, ForWriting, True)
Dim myCSV
Dim a001
Do While Not oFR.AtEndOfStream
myCSV = Split(oFR.ReadLine,",")
a001 = Mid(Space(16) & myCSV(4),Len(myCSV(4))+1,16)
oFW.WriteLine(myCSV(0) & " " & myCSV(1) & a001)
Loop
oFW.Close
oFR.Close
Set oFW = Nothing
Set oFR = Nothing
Set oFS = Nothing
MsgBox "処理終了"
＜20180715追記＞スタックオーバになるときなど用
テキストデータ複数キーの場合、こちらが使えるかも です。
自己記事 「便利 ADO でSORT」 テキストデータのソートです。
https://blog.goo.ne.jp/tkhs1732/e/37df39c1834c4c2bd4337956bf3675f4
