二分法插入排序

Option Explicit
Dim brr(), x&, gd
Public Sub Sort14() '二分查找插入排序（稳定）
    Dim t!, arr(), i&, j&, n&, rng_h&
    t = Timer()
    Sht.Activate
    Range("i3:i" & Rows.Count).ClearContents
    rng_h = Range("a" & Rows.Count).End(xlUp).Row
    If rng_h < 3 Then
        End
    ElseIf rng_h = 3 Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = Range("a3").Value
    Else
        arr = Range("a3:a" & rng_h).Value
    End If
    n = UBound(arr, 1)
    ReDim brr(1 To n)
    For i = 1 To n
        brr(i) = arr(i, 1)
    Next i
    If brr(1) > brr(2) Then gd = brr(1): brr(1) = brr(2): brr(2) = gd
    For i = 3 To n
        gd = brr(i) '储存当前拟插入值
        x = i '储存当前拟插入值序号
        If brr(i) < brr(i - 1) Then Call DG_efcz(1, i - 1)
    Next i
    For i = 1 To n
        arr(i, 1) = brr(i)
    Next i
    Range("i3").Resize(n, 1).Value = arr
    Range("i2").Value = Timer() - t
End Sub

Public Sub DG_efcz(l&, r&) '有序区数组左起点、右起点
    Dim c1&, c2&, i&, j&
    c1 = Int((l + r) / 2)
    c2 = c1 + 1
    If brr(x) >= brr(c1) And brr(x) < brr(c2) Then '若同时brr(x) <= brr(c2)的话则不稳定
        For i = x - 1 To c2 Step -1
            brr(i + 1) = brr(i)
        Next i
        brr(c2) = gd
    ElseIf brr(x) < brr(c1) Then
        If c1 = l Then
            If brr(x) < brr(l) Then j = l Else j = l + 1
            For i = x - 1 To j Step -1
                brr(i + 1) = brr(i)
            Next i
            brr(j) = gd
        Else
            Call DG_efcz(l, c1)
        End If
    ElseIf brr(x) >= brr(c2) Then
        Call DG_efcz(c2, r)
    End If
End Sub