vba【超高速！二次元配列のNon Recursive Merge Sort（Stable Sort）・一次元配列版も】

vbaで2次元配列をマージソートをする必要があり、海外のサイトなどもいろいろ調べてみたんだけど、2次元配列のマージソートのソースを公開しているページを見つけられなかったので書いてみました。

ソートのプログラムの実装の必要性について

ネットで二次元配列のソートについて調べると「ワークシートに値を張り付けてエクセルの標準の機能でソートすればいい」という意見をよく目にしますが、それでは対処できないケースもあります。

例えば、二次元配列にRangeやクラスのインスタンス等のオブジェクト型の変数を入れている場合。
また例えば、データが多すぎてエクセルに張り付けられる上限を超える場合。

残念ながらシートにインスタンスは張り付けられないし、数百万行のデータをシートに張り付けることは不可能です。
これらの問題を解決するために、この記事を書きました。

なぜマージソートである必要があるか

ソートには大きく分けて、安定ソートと不安定ソートの2種類があります。
以下の記事が参考になります。
安定なソート | アルゴリズムとデータ構造 | Aizu Online Judge

要は、エクセルのオートフィルタで2列以上昇順に並び替えるような操作（複数キーでのソート）を、2次元配列に対してプログラムで行いたい場合は、安定ソートが必要になります。

不安定ソートの代表格は誰もが知ってるクイックソート。
並び替えてはくれるけど、同値があった場合、前の並び順は無視されますので、2次元配列の2列に対してソートをかけたとしたら、1回目に実行したソートは意味がなくなります。

一方、安定ソートの代表格はタイトルにあるマージソートやバブルソート。
同値があった場合でも、前の並び順が維持されているので、2次元配列の2列に対してソートをかけたとしたら、1回目に実行したソートの並び順を維持したまま、2回目のソートがかけられます。

特徴としては、安定ソートの方が遅く、メモリもたくさん食うけど、前の並び順を生かしたままソートしてくれるので、使える場面が不安定ソートよりずっと多いです。
計算量を考えても安定ソートでかつクイックソートと同じ計算量(O(n log n))で実行できるマージソートは非常にいろんなところで活躍しています。

今回2次元配列の安定ソートがどうしても必要になったので、有名どころで一番高速なマージソートをvba版で実装してみました。

非再起ループ

再起ループの中で今回のソート関数が使用される想定のため、さらにそこで再起のマージソートを行うと、スタックメモリが枯渇するケースがあったので、非再起ループにしました。

高速化のための参照渡し

配列の値渡しは、非常にオーバーヘッドが大きいです。
なにせ呼び出された関数側では渡された配列と同等のメモリ領域をコピーしますので、その処理はコンピュータにかなりの負荷を掛けます。
マージソートを実装してみたけど思ったように速度が出ないと書いてあるサイトも結構あるのですが、こういったメモリへの読み書きへの配慮がかけているためです。
基本的にはクイックソートと同程度の速度がでるはずです。
速度が出なければ処理方法に何らかの問題があります。
余談ですがredimも同様にオーバーヘッドが大きいので極力使うべきではないです。
ループの中で配列を1要素分増やす度にRedim Preserveしていては、元々の配列に割り当てられたメモリ領域のとなりのメモリ領域が空いていればそのまま今のポインタを移動させずにメモリ拡張できるのですが、空いていなかった場合はもっと大きな領域にポインタを移動させ、メモリ内容もコピーする必要がありますので当然重くなります。

一方、参照渡しであれば、配列の先頭ポインタを渡すだけなので、配列が使用しているメモリ領域をコピーすることもなく、高速に呼び出された関数側が渡された配列にアクセスできます。
あらかじめ作業用の大きな配列を確保しておき参照渡しで渡しておけば、配列のメモリを割り当ててはガベージコレクタで消されるといった無駄な負荷をPCにかけることなく処理できます。

ソース

それなりに長ったらしいのですが

Private Sub merge_sort2(ByRef arr As Variant, ByVal col As Long)
    Dim irekae As Variant
    Dim indexer As Variant
    Dim tmp1() As Variant
    Dim tmp2() As Variant
    Dim i As Long
    ReDim irekae(LBound(arr, 1) To UBound(arr, 1))
    ReDim indexer(LBound(arr, 1) To UBound(arr, 1))
    ReDim tmp1(LBound(arr, 1) To UBound(arr, 1))
    ReDim tmp2(LBound(arr, 1) To UBound(arr, 1))
    For i = LBound(arr, 1) To UBound(arr, 1) Step 2
        If i + 1 > UBound(arr, 1) Then
            irekae(i) = arr(i, col)
            indexer(i) = i
            Exit For
        End If
        If arr(i + 1, col) < arr(i, col) Then
            irekae(i) = arr(i + 1, col)
            irekae(i + 1) = arr(i, col)
            indexer(i) = i + 1
            indexer(i + 1) = i
        Else
            irekae(i) = arr(i, col)
            irekae(i + 1) = arr(i + 1, col)
            indexer(i) = i
            indexer(i + 1) = i + 1
        End If
    Next
    Dim st1 As Long
    Dim en1 As Long
    Dim st2 As Long
    Dim en2 As Long
    Dim n As Long
    i = 1
    Do While i * 2 <= UBound(arr, 1)
        i = i * 2
        n = 0
        Do While en2 + i - 1 < UBound(arr, 1)
            n = n + 1
            st1 = i * 2 * (n - 1) + LBound(arr, 1)
            en1 = i * 2 * (n - 1) + i - 1 + LBound(arr, 1)
            st2 = en1 + 1
            en2 = IIf(st2 + i - 1 >= UBound(arr, 1), UBound(arr, 1), st2 + i - 1)
            Call merge2(irekae, indexer, tmp1, tmp2, st1, en1, st2, en2)
        Loop
        en2 = 0
    Loop
    Dim ret As Variant
    ReDim ret(LBound(arr, 1) To UBound(arr, 1), LBound(arr, 2) To UBound(arr, 2))
    For i = LBound(arr, 1) To UBound(arr, 1)
        For n = LBound(arr, 2) To UBound(arr, 2)
            If IsObject(arr(indexer(i), n)) Then
                Set ret(i, n) = arr(indexer(i), n)
            Else
                ret(i, n) = arr(indexer(i), n)
            End If
        Next
    Next
    arr = ret
End Sub

Private Sub merge2(ByRef irekae As Variant, _
ByRef indexer As Variant, _
ByRef tmpArr() As Variant, _
ByRef tmpIndexer() As Variant, _
ByVal st1 As Long, _
ByVal en1 As Long, _
ByVal st2 As Long, _
ByVal en2 As Long)
    Dim j As Long
    Dim n As Long
    Dim i As Long
    For i = st1 To en2
        tmpArr(i) = irekae(i)
        tmpIndexer(i) = indexer(i)
    Next
    j = st1
    n = st2
    Do While (j < en1 + 1 Or n < en2 + 1)
        If n >= en2 + 1 Then
            irekae(j + n - st2) = tmpArr(j)
            indexer(j + n - st2) = tmpIndexer(j)
            j = j + 1
        ElseIf j < en1 + 1 And tmpArr(j) <= tmpArr(n) Then
            irekae(j + n - st2) = tmpArr(j)
            indexer(j + n - st2) = tmpIndexer(j)
            j = j + 1
        Else
            irekae(j + n - st2) = tmpArr(n)
            indexer(j + n - st2) = tmpIndexer(n)
            n = n + 1
        End If
    Loop
End Sub

こんな呼び出しかたができます。

Dim a As Variant
Range("A1:B1048576").Select
a = Selection.Value
Call merge_sort2(a, 2) 'aの二次元配列に対して、2列目をキーにして並べ替えを行う。

実行結果（クイックソートとの比較）

エクセルいっぱいの104万行×2列程度の要素数で、クイックソートでは平均約8秒のものが、今回作ったマージソートでは平均9秒でした。
メモリ量はクイックソート実行時のおよそ3倍程度に収まりました。

ちなみにマージソートとの比較検証用のクイックソートは下記サイトのものを使わせていただきました。
excel-ubara.com

安定ソートでそれだけの速度が出せたのだから、非常に満足いくものになりました。

ついでに一次元配列版は以下になります。

Private Sub merge_sort(ByRef arr As Variant)
    Dim irekae As Variant
    Dim i As Long
    ReDim irekae(LBound(arr) To UBound(arr))
    Dim tmp1() As Variant
    ReDim tmp1(LBound(arr, 1) To UBound(arr, 1))
    For i = LBound(arr) To UBound(arr) Step 2
        If i + 1 > UBound(arr) Then
            irekae(i) = arr(i)
            Exit For
        End If
        If arr(i + 1) < arr(i) Then
            irekae(i) = arr(i + 1)
            irekae(i + 1) = arr(i)
        Else
            irekae(i) = arr(i)
            irekae(i + 1) = arr(i + 1)
        End If
    Next
    Dim st1 As Long
    Dim en1 As Long
    Dim st2 As Long
    Dim en2 As Long
    Dim n As Long
    i = 1
    Do While i * 2 <= UBound(arr)
        i = i * 2
        n = 0
        Do While en2 + i - 1 < UBound(arr)
            n = n + 1
            st1 = i * 2 * (n - 1) + LBound(arr)
            en1 = i * 2 * (n - 1) + i - 1 + LBound(arr)
            st2 = en1 + 1
            en2 = IIf(st2 + i - 1 >= UBound(arr), UBound(arr), st2 + i - 1)
            Call merge(irekae, tmp1, st1, en1, st2, en2)
        Loop
        en2 = 0
    Loop
    arr = irekae
End Sub
Private Sub merge(ByRef irekae As Variant, _
ByRef tmpArr() As Variant, _
ByVal st1 As Long, _
ByVal en1 As Long, _
ByVal st2 As Long, _
ByVal en2 As Long)
    Dim j As Long
    Dim n As Long
    Dim i As Long
    For i = st1 To en2
        tmpArr(i) = irekae(i)
    Next
    j = st1
    n = st2
    Do While (j < en1 + 1 Or n < en2 + 1)
        If n >= en2 + 1 Then
            irekae(j + n - st2) = tmpArr(j)
            j = j + 1
        ElseIf j < en1 + 1 And tmpArr(j) <= tmpArr(n) Then
            irekae(j + n - st2) = tmpArr(j)
            j = j + 1
        Else
            irekae(j + n - st2) = tmpArr(n)
            n = n + 1
        End If
    Loop
End Sub

こちらは104万要素をソートした場合、クイックソートが約3秒なのに比べて、上記マージソートが約4.5秒でした。
クイックソートにはかなわないけど、安定ソートとして十分な性能が出ているとおもいます。

マージソートを一次元配列で使用するケースはあまりないと思いますが参考までに…。

--
2017/9/6追記
降順ソートの要望がコメントにありましたので追記します。
不等号を数カ所反対にしただけなのですが、コピペで使えるよう丸っと載せます。

Private Sub merge_sort2_desc(ByRef Arr As Variant, ByVal Col As Long)
    Dim irekae As Variant
    Dim indexer As Variant
    Dim tmp1() As Variant
    Dim tmp2() As Variant
    Dim i As Long
    ReDim irekae(LBound(Arr, 1) To UBound(Arr, 1))
    ReDim indexer(LBound(Arr, 1) To UBound(Arr, 1))
    ReDim tmp1(LBound(Arr, 1) To UBound(Arr, 1))
    ReDim tmp2(LBound(Arr, 1) To UBound(Arr, 1))
    For i = LBound(Arr, 1) To UBound(Arr, 1) Step 2
        If i + 1 > UBound(Arr, 1) Then
            irekae(i) = Arr(i, Col)
            indexer(i) = i
            Exit For
        End If
        If Arr(i + 1, Col) > Arr(i, Col) Then
            irekae(i) = Arr(i + 1, Col)
            irekae(i + 1) = Arr(i, Col)
            indexer(i) = i + 1
            indexer(i + 1) = i
        Else
            irekae(i) = Arr(i, Col)
            irekae(i + 1) = Arr(i + 1, Col)
            indexer(i) = i
            indexer(i + 1) = i + 1
        End If
    Next
    Dim st1 As Long
    Dim en1 As Long
    Dim st2 As Long
    Dim en2 As Long
    Dim n As Long
    i = 1
    Do While i * 2 <= UBound(Arr, 1)
        i = i * 2
        n = 0
        Do While en2 + i - 1 < UBound(Arr, 1)
            n = n + 1
            st1 = i * 2 * (n - 1) + LBound(Arr, 1)
            en1 = i * 2 * (n - 1) + i - 1 + LBound(Arr, 1)
            st2 = en1 + 1
            en2 = IIf(st2 + i - 1 >= UBound(Arr, 1), UBound(Arr, 1), st2 + i - 1)
            Call merge2desc(irekae, indexer, tmp1, tmp2, st1, en1, st2, en2)
        Loop
        en2 = 0
    Loop
    Dim ret As Variant
    ReDim ret(LBound(Arr, 1) To UBound(Arr, 1), LBound(Arr, 2) To UBound(Arr, 2))
    For i = LBound(arr, 1) To UBound(arr, 1)
        For n = LBound(arr, 2) To UBound(arr, 2)
            If IsObject(arr(indexer(i), n)) Then
                Set ret(i, n) = arr(indexer(i), n)
            Else
                ret(i, n) = arr(indexer(i), n)
            End If
        Next
    Next
    Arr = ret
End Sub

Private Sub merge2desc(ByRef irekae As Variant, _
ByRef indexer As Variant, _
ByRef tmpArr() As Variant, _
ByRef tmpIndexer() As Variant, _
ByVal st1 As Long, _
ByVal en1 As Long, _
ByVal st2 As Long, _
ByVal en2 As Long)
    Dim j As Long
    Dim n As Long
    Dim i As Long
    For i = st1 To en2
        tmpArr(i) = irekae(i)
        tmpIndexer(i) = indexer(i)
    Next
    j = st1
    n = st2
    Do While (j < en1 + 1 Or n < en2 + 1)
        If n >= en2 + 1 Then
            irekae(j + n - st2) = tmpArr(j)
            indexer(j + n - st2) = tmpIndexer(j)
            j = j + 1
        ElseIf j < en1 + 1 And tmpArr(j) >= tmpArr(n) Then
            irekae(j + n - st2) = tmpArr(j)
            indexer(j + n - st2) = tmpIndexer(j)
            j = j + 1
        Else
            irekae(j + n - st2) = tmpArr(n)
            indexer(j + n - st2) = tmpIndexer(n)
            n = n + 1
        End If
    Loop
End Sub

hiroshi akutsuの日記

主にプログラミング関係のこと