用VBA实现对一维数组的排序(4)希尔排序

非专业，有错请批评，谢谢。

希尔排序是插入排序的一种,是插入排序的一种改进型.其效率比插入排序要高,但是也带来了不稳定的坏处(插入排序是稳定的排序),由于我们在二维数组多列排序中引入了字典一个方向上记录行号,又在一个方向里输出行号所以其实已经避免了不稳定的风险,所以稳定性不在我们的考虑范围内.

我们先看看插入排序

在插入排序中,我们每次都将一个待排序的元素，按其大小插入到前面已经排好序的一组元素的适当位置上去，直到元素全部插入为止.这就是插入排序的基本过程,看上图.

那么这里我要介绍一个另外一种插入排序,叫折半插入排序,他与插入排序的唯一却别就在于,他不是从排好序的元素中挨个儿元素去对比,而是每次都对比中间的数字,这样能最快速度的确定待排序元素大概是在上半部分还是下半部分,然后再去中点再对比,这种方式就叫折半查找法,效率高速度快,但是我没有将其编入到七大排序中,因为排序种类太多了,会一种就够用了,加上这种排序是改进型,理解起来不难,所以不作为案例.希尔排序理解虽然也是改进型,但是就算是学习了插入排序的基础理解起来也很难.所以我们引用他最为七个常见排序的案例.

前面说到的折半查找法,待排元素通过与排好序中间的元素对比,快速确定其大致定位,重复此动作能大量减少对比,从而加快了排序速度,这样的排序方式难度较小容易理解也容易实现,希尔排序同样也是减少对比,那么希尔排序是怎么做的呢?为什么他比较快呢?先看案例

11 3 9 2 19 18 22 1 10 15 16 7 5 10 13 8 7 14 17 4 5 7 10 20

这几个数字排序,明显这组数字是乱序的,在希尔排序中,首先是将数据分组处理的(重点),我们可以认为这是规整数据.先看看代码中分组处理后的效果是怎么样的

******************************************************************************

Sub 希尔排序原理演示()

Dim 间距 As Long

Dim i As Long

Dim t As Long

Dim 暂存 As Long

Dim iLBound As Long

Dim iUBound As Long

Dim 数据个数 As Long

    最大行 = Range("a65536").End(xlUp).Row

Rem 最大行号求出来,用来计算数据量

    数据个数 = 最大行

    间距 = 1 '初始间距

Rem 当间距为1的时候，希尔排序就是插入排序，希尔排序本身就是插入排序的改良

    If 数据个数 > 13 Then

        Do While 间距 < 数据个数

            间距 = (3 * 间距) + 1

        Loop

Rem 间距的算法是固定写法，不要过于纠结，这是经过别人验证取间距最好的办法

        间距 = 间距 \ 9

Rem 反斜杠的意思是取除法结果的整数部分,类似于int函数

    End If

    Do While 间距 '当间距<>0的时候其实就是间距为真，do 判断为真执行

Rem 这里巧妙的利用了0的特点，0 就是false

Rem 间距不为0的时候一直排序,间距一直减小,直到小于1

Rem *****注意这以下其实跟插入排序相差无几,无非就是step由-1变成了-间距*****

        For i = 1 + 间距 To 24

        暂存 = Range("a" & i)

            For t = i - 间距 To 1 Step -间距

            Union(Range("a" & t + 间距), Range("a" & t)).Select

                If Range("a" & t) <= 暂存 Then Exit For

            Range("a" & t + 间距) = Range("a" & t)

            Next t

        Range("a" & t + 间距) = 暂存

        Next i

    间距 = 间距 \ 3

Rem 间距总有到0的那一刻

    Loop’复制代码调试的时候在这里打断点,可以得到希尔排序分组处理数据的结果

End Sub

‘这是希尔排序在excel单元格中的演示代码,感兴趣的同学可以复制粘贴,按F8去自己调试,如果不知道怎么调试,我推荐郑广学老师的课程,课程里面就有详细的调试解读,我就不累述了,篇幅越来越大了,再大就没人看了

*******************************************************************************

这是希尔排序的演示代码

那么希尔排序是怎么分组的呢?

第一步:取一个间距.本案例取间距为4,间距的算法后面会说到

第二步:跳跃式插入排序

第三步:缩小间距,重复第一第二步

提示:当间距缩小到1的时候,其实就是插入排序

希尔排序处理数据的过程如下图

 

注:图中有希尔排序为何不稳定的奥秘

为什么说希尔排序比插入排序快?我们首先来宏观角度观察一下

这个是希尔排序在分组插入排序规整数据前的结果,我们能清晰的看到其内部是杂乱无章的.

 将数据分组插入排序后的结果,可以看到虽然没有完成排序,但是趋势上大体接近排序结果了.

以本案例来说,第一次间距取4,第二次间距取1,取1的时候其实就是插入排序,换句话说在简单的处理了几组数据后我们换来了一个新的接近结果的数组,这样一个数组是有利于最后一步的插入排序的,比直接插入排序的效率更快.

不妨我们再从微观角度来观察一下

我们以4为例,直接插入排序需要16步对比,而希尔排序只需要10步,从单个元素对比的角度看,希尔排序比插入排序更快

下面,我们来看看一维数组排序的代码,二维数组多列排序的过程就是在此代码的基础上修改,增加完善的.感兴趣的朋友可以自己去调试一下.这不是重点,重点是二维数组的多列排序.

*******************************************************************************‘下面是数组的排序模型,后面会修改他来完成二维数组多列排序

Function 数组希尔排序模型(arr)

Dim 间距 As Long

Dim i As Long

Dim t As Long

Dim 暂存 As Long

Dim iLBound As Long

Dim iUBound As Long

Dim 数据个数 As Long

iLBound = LBound(arr)

iUBound = UBound(arr)

    数据个数 = (iUBound - iLBound) + 1

    间距 = 1

Rem 当间距为1的时候，希尔排序就是插入排序，希尔排序本身就是插入排序的改良

    If 数据个数 > 13 Then

        Do While 间距 < 数据个数

            间距 = (3 * 间距) + 1

        Loop

        间距 = 间距 \ 9

    End If

    Do While 间距

    '当间距<>0的时候其实就是间距为真，真在代码里用1表示，假用0，do 判断为真执行

Rem 这里巧妙的利用了0的特点，0 就是false

        For i = iLBound + 间距 To iUBound

        暂存 = arr(i)

            For t = i - 间距 To iLBound Step -间距

                If arr(t) <= 暂存 Then Exit For

            arr(t + 间距) = arr(t)

            Next t

        arr(t + 间距) = 暂存

        Next i

    间距 = 间距 \ 3

Rem 间距总有到0的那一刻

    Loop

    数组希尔排序模型 = arr

End Function

Sub 希排测试()

Dim arr()

arr = Array(10, 22, 32, 1, 12, 18, 30, 45, 22, 30, 30, 80, 55, 96, 69, 46, 49, 92, 42, 71, 2, 3, 14, 15, 10, 0, 100)

数组希尔排序模型 arr

End Sub

‘这是测试代码

*******************************************************************************

最基础的问题基本上解决了,但是还有一个坑没填:间距怎么取?

间距的取法有多种,间距取得不好对排序速度哟很大影响,但是我用了一种前人总结好的去间距的方发.

 

    不要太过于纠结怎么去间距最好,这种方法直接套用就行了,就像本文中的排序函数,直接套用就行了,输入参数能得到就能得到相对应的结果.本文的目的其实只是帮助理解最基础的七个对比排序罢了.能理解其中一个两个就够用了.

下面就是二维数组多列排序,代码功能上支持5列以上排序,在经过修改后能支持更多列排序,只不过是因为担心栈溢出,所以做了限制,功能上我的函数每一列都支持自由升序降序.具体的代码详解可以看我前面的文章:”利用一维数组排序实现二维数组的多列自由升降序函数封装的详解”

函数的用法如下:

函数:多列希尔修整数组(数组arr  ,  “+4,-5,+6,-7” , 起始行 , 终止行)

参数说明:

(1)数组arr:需要排序的数组

(2):排序主次列,引号内主列-次列-次次列,为避免代码出现栈溢出,我做了限制,最多支持8行数据的排序

(3)起始行与终止行:数组需要排序部分的起始行和终止行,如第三行开始到52行这个区域需要排序,起始行就是3,终止行就是52

备注:本函数支持数组局部排序.此功能常用于表头部分不参与排序的情况

事例以及上述代码的测试

1. Sub 多列希尔测试()
2. arr = Sheet6.Range("a1:g52")
3. 多列希尔排序模块 arr, "+4,-5,+6,-7", 3, 52
4. Sheet6.Range("j1").Resize(52, 7) = arr '输出检验点
5. End Sub

*******************************************************************************

Function 数组希尔排序升序(arr, 起始行, 终止行)

Dim 间距 As Long

Dim i As Long

Dim t As Long

Dim 暂存 As Long

Dim iLBound As Long

Dim iUBound As Long

Dim 数据个数 As Long

iLBound = 起始行

iUBound = 终止行

    数据个数 = (iUBound - iLBound) + 1

    间距 = 1

    If 数据个数 > 13 Then

        Do While 间距 < 数据个数

            间距 = (3 * 间距) + 1

        Loop

        间距 = 间距 \ 9

    End If

    Do While 间距

        For i = iLBound + 间距 To iUBound

        暂存 = arr(i)

            For t = i - 间距 To iLBound Step -间距

                If arr(t) <= 暂存 Then Exit For

            arr(t + 间距) = arr(t)

            Next t

        arr(t + 间距) = 暂存

        Next i

    间距 = 间距 \ 3

    Loop

    数组希尔排序升序 = arr

End Function

_______________________________________________________________________________

Function 数组希尔排序降序(arr, 起始行, 终止行)

Dim 间距 As Long

Dim i As Long

Dim t As Long

Dim 暂存 As Long

Dim iLBound As Long

Dim iUBound As Long

Dim 数据个数 As Long

iLBound = 起始行

iUBound = 终止行

    数据个数 = (iUBound - iLBound) + 1

    间距 = 1

    If 数据个数 > 13 Then

        Do While 间距 < 数据个数

            间距 = (3 * 间距) + 1

        Loop

        间距 = 间距 \ 9

    End If

    Do While 间距

        For i = iLBound + 间距 To iUBound

        暂存 = arr(i)

            For t = i - 间距 To iLBound Step -间距

                If arr(t) >= 暂存 Then Exit For

            arr(t + 间距) = arr(t)

            Next t

        arr(t + 间距) = 暂存

        Next i

    间距 = 间距 \ 3

    Loop

    数组希尔排序降序 = arr

End Function

_____________________________________________________________________________

Private Function 行号记录字典(All, 值列, 数组索引起点, 数组索引终点, Optional 功能 = 0)

Dim dic '创建字典，采用引用法

    Set dic = CreateObject("Scripting.Dictionary")

'Dim Dic As New Dictionary '(勾选引用法)

    For i = 数组索引起点 To 数组索引终点

        Key = All(i, 值列)

        If dic.Exists(Key) = False Then

        Rem 不存在key的时候item就等于i,避免下面的 xxx & xxx 录入一个空值

            dic(Key) = i

        Else

            dic(Key) = dic(Key) & "=*=" & i

        End If

    Next

    Rem 根据功能选择输出

    If 功能 = 0 Then

        行号记录字典 = dic.keys '输出字典

    ElseIf 功能 = 1 Then

        行号记录字典 = dic.Items '输出值列

    Else

        Set 行号记录字典 = dic '输出关键字列

    End If

End Function_______________________________________________________________________________

Private Function 单列希尔排序模块(arr, 值列, 起点, 终点)

Dim 升降 As Boolean

If 值列 < 0 Then

    值列 = Abs(值列)

    升降 = False

ElseIf 值列 > 0 Then

    值列 = Abs(值列)

    升降 = True

End If

ReDim arr_son(起点 To 终点, LBound(arr, 2) To UBound(arr, 2))

Set dic = 行号记录字典(arr, 值列, 起点, 终点, 3)

    arr_rows = dic.keys

    If 升降 = True Then

        arr_rows = 数组希尔排序升序(arr_rows, LBound(arr_rows), UBound(arr_rows))

    Else

        arr_rows = 数组希尔排序降序(arr_rows, LBound(arr_rows), UBound(arr_rows))

    End If

ReDim brr(LBound(arr_rows) To UBound(arr_rows))

    For i = LBound(arr_rows) To UBound(arr_rows)

        brr(i) = dic(arr_rows(i))

    Next

    g = 起点

    For i = LBound(brr) To UBound(brr)

        crr = Split(brr(i), "=*=")

        For t = LBound(crr) To UBound(crr)

            For h = LBound(arr, 2) To UBound(arr, 2)

                arr_son(g, h) = arr(Abs(crr(t)), h)

            Next

            g = g + 1

        Next

    Next

    For i = 起点 To 终点

        For t = LBound(arr, 2) To UBound(arr, 2)

            arr(i, t) = arr_son(i, t)

        Next

    Next

End Function

Private Function 多列希尔排序模块(arr, 值列串, 起点, 终点, Optional 递推 = 0)

    arr_值组 = Split(值列串, ",")

    s = UBound(arr_值组)

    If 递推 > s Then Exit Function

    If 递推 > 5 Then Exit Function

    单列希尔排序模块 arr, Val(arr_值组(递推)), 起点, 终点

    brr = 行号记录字典(arr, Abs(arr_值组(递推)), 起点, 终点, 1)

    For t = LBound(brr) To UBound(brr)

        crr = Split(brr(t), "=*=")

        If UBound(crr) > 0 Then

            多列希尔排序模块 arr, 值列串, crr(LBound(crr)), crr(UBound(crr)), 递推 + 1

        End If

    Next

End Function

*******************************************************************************

这里在分享一下原实验数据和结果