『マージソート』 ～ 車輪の再発明シリーズ ～ http://www.moug.net/faq/viewtopic.php?t=66006

Module1.bas

Option Explicit

' マージソート

Function MergeSort(List) As Variant
    Dim Lists As Variant
    If ArrayCount(List) <= 1 Then
        MergeSort = List
    Else
        Lists = Bisect(List) ' 配列を2分する
        Lists(0) = MergeSort(Lists(0))
        Lists(1) = MergeSort(Lists(1))
        MergeSort = Merge(Lists(0), Lists(1))
    End If
End Function

Function Merge(List1, List2) As Variant
    Dim Len1 As Long
    Dim Len2 As Long
    Dim Result As Variant
    Dim a As Variant
    Dim b As Variant
    Dim i As Long
    Dim j As Long
    Dim k As Long
    
    Len1 = ArrayCount(List1)
    Len2 = ArrayCount(List2)
    ReDim Result(Len1 + Len2 - 1)
    
    a = List1(0)
    b = List2(0)
    i = 0
    j = 0
    k = 0

    Do
        If Compare(a, b) <= 0 Then
            Result(i) = a
            i = i + 1
            j = j + 1
            If j < Len1 Then
            Else
                Exit Do
            End If
            a = List1(j)
        Else
            Result(i) = b
            i = i + 1
            k = k + 1
            If k < Len2 Then
            Else
                Exit Do
            End If
            b = List2(k)
        End If
    Loop

    Do While j < Len1
        Result(i) = List1(j)
        i = i + 1
        j = j + 1
    Loop
    Do While k < Len2
        Result(i) = List2(k)
        i = i + 1
        k = k + 1
    Loop
    
    Merge = Result
End Function

Module2.bas

Option Explicit

' 配列の要素数をカウント

Sub ArrayCountTest()
    Dim List
    
    Debug.Assert ArrayCount(Array()) = 0
    Debug.Assert ArrayCount(Array(1, 2, 3)) = 3
    
    ReDim List(-10 To -3)
    Debug.Assert ArrayCount(List) = 8
    
    ReDim List(-2 To 3)
    Debug.Assert ArrayCount(List) = 6
End Sub

Function ArrayCount(List) As Long
    Dim Lower As Long
    Dim Upper As Long
    
    Lower = LBound(List)
    Upper = UBound(List)
    
    If Lower > Upper Then
        ArrayCount = 0
    Else
        ArrayCount = Abs(Upper - Lower) + 1
    End If
End Function

Module3.bas

Option Explicit

' 配列を2分する

Sub BisecTest()
    Dim Result
    
    Result = Bisect(Array("a", "b", "c", "d"))
    Debug.Assert Join(Result(0), "") = "ab"
    Debug.Assert Join(Result(1), "") = "cd"
    
    Result = Bisect(Array("a", "b", "c", "d", "e"))
    Debug.Assert Join(Result(0), "") = "abc"
    Debug.Assert Join(Result(1), "") = "de"
End Sub

Function Bisect(List) As Variant
    Dim Count As Long
    Dim half As Long
    Dim List1 As Variant
    Dim List2 As Variant
    Dim n As Long
    Dim i As Long
    Dim j As Long
    
    Count = ArrayCount(List)
    half = Fix(Count / 2 + 0.5)
    ReDim List1(half - 1)
    ReDim List2(half - 1 - (Count Mod 2))
    
    n = half - 1
    For i = 0 To n
        List1(i) = List(i)
    Next i
    
    j = -1
    n = Count - 1
    For i = half To n
        j = j + 1
        List2(j) = List(i)
    Next i
    
    Bisect = Array(List1, List2)
End Function

Module4.bas

Option Explicit

' マージソートで使われる比較関数

#Const Pettern = 2

#If Pettern = 1 Then

    Sub MergeSortTest()
        Dim List
        
        List = Array(8, 4, 3, 7, 6, 5, 2, 1)
        Debug.Assert Join(MergeSort(List), "") = "12345678"
    End Sub
    
    Sub CompareTest()
        Debug.Assert Compare(-10, 0) = -1
        Debug.Assert Compare(5, 5) = 0
        Debug.Assert Compare(10, 5) = 1
    End Sub
    
    Function Compare(a, b) As Integer
        Compare = NumComp(a, b)
    End Function

#ElseIf Pettern = 2 Then

    Sub MergeSortTest()
        Dim a, b, c, d, e, List, Result
        Dim i As Long
        Dim JoinedResult As Long
        
        a = Array("A", 10, "hoge")
        b = Array("A", 5, "fuga")
        c = Array("B", 10, "hoge")
        d = Array("B", 5, "fuga")
        e = Array("B", 10, "test")
        
        List = Array(a, b, c, d, e)
        Result = MergeSort(List)
        For i = LBound(Result) To UBound(Result)
            Result(i) = "[" & Join(Result(i), ",") & "]"
        Next i
        Debug.Assert Join(Result, ",") = _
            "[A,5,fuga],[A,10,hoge],[B,5,fuga],[B,10,hoge],[B,10,test]"
    End Sub
    
    Sub CompareTest()
        Dim a, b
        
        a = Array("A", 5, "hoge")
        b = Array("A", 10, "fuga")
        Debug.Assert Compare(a, b) = -1
        
        a = Array("A", 10, "hoge")
        b = Array("A", 10, "fuga")
        Debug.Assert Compare(a, b) = 0
        
        a = Array("A", 10, "hoge")
        b = Array("A", 5, "fuga")
        Debug.Assert Compare(a, b) = 1
    End Sub
    
    Function Compare(a, b) As Integer
        Dim Result As Integer
        
        ' 1列目は文字列として比較
        Result = StrComp(a(0), b(0), vbBinaryCompare)
        If Result = 0 Then
            ' 2列目は数値として比較
            Result = NumComp(a(1), b(1))
        End If
        
        Compare = Result
    End Function

#End If

Module5.bas

Option Explicit

' 数値として比較

Sub NumCompTest()
    Debug.Assert NumComp(5, 10) = -1
    Debug.Assert NumComp(5, 5) = 0
    Debug.Assert NumComp(10, 5) = 1
End Sub

Function NumComp(a, b) As Integer
    NumComp = Sgn(a - b)
End Function