用VBA实现对一维数组的排序(7)堆排序

想要学习堆排序,就先的了解一点二叉树和堆的基础,这里我们不讲概念,直接上图先看看堆和二叉树的样子,认识一下这俩结构.

通过图,我们一目了然,

 

这就是一个典型的二叉树结构,

 

上图左边是一格最小的二叉树结构,是完全二叉树一个顶点连接两个点或一个左边的点,顶点称为父节点,下面的称为子节点子节点必须先有左边才有右边或者只有左边,如此才成为完全二叉树,,否则就是非完全二叉树,在堆排序中,我们不能出现非完全二叉树

那什么是堆呢?

当一个完全二叉树的父节点大于(大根堆)或小于(小根堆)该最小完全二叉树的所有子节点的时候,我们将其称为堆,堆,从宏观来看,顶端永远是最值,如果每次我们都将这个最值拿出来,再将剩下的数据调成堆,就又能找到剩余数据中的最值,这个动作是不是有点熟悉?没错这组动作恰好就是排序.我们看图,看图比文字更为直观,能更快的理解

第一步,将数据摆成一个二叉树,实际上二叉树和堆是不存在的,是人为的赋予的一种关系,

第二步,将二叉树转换为堆

 

 

 

 

 

 

 

 

 

这是大神写的一维数组的升序的代码,注释一应俱全

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

Public Sub HeapSortFunction升(arr)

  iLength = UBound(arr)

  Call BuildMaxHeap升(arr, iLength) ' 创建大顶推（初始状态看做：整体无序）

  For i = iLength To 1 Step -1

  Call Swap(arr(0), arr(i), 0, i) ' 将堆顶元素依次与无序区的最后一位交换（使堆顶元素进入有序区）

  Call MaxHeapify升(arr, 0, i) '重新将无序区调整为大顶堆

  Next i

End Sub

' 创建大顶推（根节点大于左右子节点）

Private Sub BuildMaxHeap升(arr, iLength)

  '根据大顶堆的性质可知：数组的前半段的元素为根节点，其余元素都为叶节点

  For i = iLength \ 2 To 0 Step -1  '从最底层的最后一个根节点开始进行大顶推的调整

  Call MaxHeapify升(arr, i, iLength + 1) '调整大顶堆

  Next i

End Sub

Private Sub MaxHeapify升(arr, currentIndex, heapSize)

  Dim left As Long

  Dim right As Long

  Dim large As Long

  left = 2 * currentIndex + 1   '左子节点在数组中的位置

  right = 2 * currentIndex + 2  '右子节点在数组中的位置

  large = currentIndex      '记录此根节点左子节点右子节点 三者中最大值的位置

  If left < heapSize Then

  If arr(left) > arr(large) Then '与左子节点进行比较

    large = left

  End If

  End If

  If right < heapSize Then

  If arr(right) > arr(large) Then '与右子节点进行比较

    large = right ';

  End If

  End If

  If currentIndex <> large Then '如果 currentIndex不等于large 则表明 large 发生变化（即：左右子节点中有大于根节点的情况）

  Call Swap(arr(currentIndex), arr(large), currentIndex, large) '将左右节点中的大者与根节点进行交换（即：实现局部大顶堆）

  Call MaxHeapify升(arr, large, heapSize) '以上次调整动作的large位置（为此次调整的根节点位置），进行递归调整

  End If

End Sub

Private Sub Swap(a, b, n1, n2)

    Dim temp As Long

    temp = a

    a = b

    b = temp

End Sub

Function 一维数组排序升序测试()

arr = Array(2, 50, 20, 6, 1, 0, 8, 4, 9, 3, 7, 22, 33, 5)

HeapSortFunction升 arr

End Function

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

这是我修改后调用了他的代码写的二维数组多列自由升序降序的代码

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

Public Function HeapSortFunction升(Myarr, 起始, 终止)

ReDim arr(0 To 终止 - 起始)

For t = 起始 To 终止

arr(t - 起始) = Myarr(t)

Next

  iLength = UBound(arr)

  Call BuildMaxHeap升(arr, iLength)

  For i = iLength To 1 Step -1

  Call Swap(arr(0), arr(i), 0, i)

  Call MaxHeapify升(arr, 0, i)

  Next i

For t = 起始 To 终止

Myarr(t) = arr(t - 起始)

Next

HeapSortFunction升 = Myarr

End Function

Private Sub BuildMaxHeap升(arr, iLength)

  For i = iLength \ 2 To 0 Step -1

  Call MaxHeapify升(arr, i, iLength + 1)

  Next i

End Sub

Private Sub MaxHeapify升(arr, currentIndex, heapSize)

  Dim left As Long

  Dim right As Long

  Dim large As Long

  left = 2 * currentIndex + 1

  right = 2 * currentIndex + 2

  large = currentIndex

  If left < heapSize Then

  If arr(left) > arr(large) Then

    large = left

  End If

  End If

  If right < heapSize Then

  If arr(right) > arr(large) Then

    large = right

  End If

  End If

  If currentIndex <> large Then

  Call Swap(arr(currentIndex), arr(large), currentIndex, large)

  Call MaxHeapify升(arr, large, heapSize)

  End If

End Sub

Public Function HeapSortFunction降(Myarr, 起始, 终止)

ReDim arr(0 To 终止 - 起始)

For t = 起始 To 终止

arr(t - 起始) = Myarr(t)

Next

  iLength = UBound(arr)

  Call BuildMaxHeap降(arr, iLength)

  For i = iLength To 1 Step -1

  Call Swap(arr(0), arr(i), 0, i)

  Call MaxHeapify降(arr, 0, i)

  Next i

For t = 起始 To 终止

Myarr(t) = arr(t - 起始)

Next

HeapSortFunction降 = Myarr

End Function

Private Sub BuildMaxHeap降(arr, iLength)

  For i = iLength \ 2 To 0 Step -1

  Call MaxHeapify降(arr, i, iLength + 1)

  Next i

End Sub

Private Sub MaxHeapify降(arr, currentIndex, heapSize)

  Dim left As Long

  Dim right As Long

  Dim large As Long

  left = 2 * currentIndex + 1

  right = 2 * currentIndex + 2

  large = currentIndex

  If left < heapSize Then

  If arr(left) < arr(large) Then

    large = left

  End If

  End If

  If right < heapSize Then

  If arr(right) < arr(large) Then

    large = right

  End If

  End If

  If currentIndex <> large Then

  Call Swap(arr(currentIndex), arr(large), currentIndex, large)

  Call MaxHeapify降(arr, large, heapSize)

  End If

End Sub

Private Sub Swap(a, b, n1, n2)

    Dim temp As Long

    temp = a

    a = b

    b = temp

End Sub

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

Dim Dic

    Set Dic = CreateObject("Scripting.Dictionary")

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

        key = ALL(i, 值列)

        If Dic.Exists(key) = False Then

            Dic(key) = i

        Else

            Dic(key) = Dic(key) & "=*=" & i

        End If

    Next

    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 = HeapSortFunction升(arr_rows, LBound(arr_rows), UBound(arr_rows))

    Else

        arr_rows = HeapSortFunction降(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 递推 > 8 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

Sub 多列归并测试()

arr = Sheet6.Range("a1:g52")

多列堆排序模块 arr, "+4,-5,+6,-7", 3, 52

Sheet6.Range("i1").Resize(52, 7) = arr

End Sub

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

函数用法:

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

arr:指需要排除的二维数组

值列串:指排序的主列,和次列数据串,以"+4,-5,+6,-7"这样的形式输入,”+”代表升序,”-”代表降序. "+4,-5,+6,-7"就是4列为主列升序,5,7为降序次列,6为升序次列.

起点: 二维数组arr需要排序部分的起始行

终点: 二维数组arr需要排序部分的终止行

多列堆排序模块最后输出一个数组就是就是排好序的数组.

关于一维数组如何升级为二维数组多列自由升序降序的过程,另有文章,可移步参考.