VBA编程技巧 之 浅谈数据结构 （不定期持续更新，最后更新130411）

JLF2003

谢谢分享，期待楼主后继大作!

lee1892

n叉树转为二叉树的示例

将前文使用单向链表构建的树转为了二叉树，附件在1楼。该附件添加了较为详细的注释，供参考。

转二叉树的代码如下，在之前ParseData时，每个节点的链接数组下标改为由 -1 开始，并使用 -1 作为左子节点，0 作为右子节点。
[code=vb]
Sub RegularTreeToBinaryTree(arrNodes, nRoot)
    ' 二叉树的节点的链接数组中，-1 为左子节点，0 为右子节点
    Dim i&, aChildren
    aChildren = arrNodes(nRoot) ' 获得子节点（原树）地址数组
    If UBound(aChildren) = 0 Then Exit Sub ' 如果没有子节点（原树）则退出
    arrNodes(nRoot)(-1) = aChildren(1) ' 第一个子节点（原树）链接为当前节点的左子节点（二叉树）
    For i = 1 To UBound(aChildren) - 1
        arrNodes(aChildren(i))(0) = aChildren(i + 1)
        ' 每个子节点的右子节点（二叉树）为当前节点的下一个子节点（原树），最后一个不用加
    Next
    For i = 1 To UBound(aChildren)
        Call RegularTreeToBinaryTree(arrNodes, aChildren(i))
        ' 递归遍历当前节点的全部子节点（原树）
    Next
    ' 保留原树的链接信息，供比较
End Sub
[/code]
这样，当访问这个二叉树时，先序遍历就可以返回与之前的n叉树的深度遍历同样的顺序，遍历代码如下：
[code=vb]
Private Sub GetChildrenFromBinaryTree(nNode, aRows, nCount&, iLayer&)
    ' 先序遍历可获得同样顺序
    Dim i&, j&, nRow&, aChildren
    aChildren = aNodes(nNode)
    If nNode <= UBound(aData) Then
    ' 产品节点作为树的根节点，没有信息，需跳过
        nCount = nCount + 1
        aRows(1, nCount) = iLayer
        aRows(2, nCount) = nNode
        ' 添加当前节点行号至结果数组
    End If
    If Not IsEmpty(aChildren(-1)) And aChildren(-1) > 1 Then
        ' 有子节点，访问子节点，即向左走
        iLayer = iLayer + 1 ' 层数 +1
        Call GetChildrenFromBinaryTree(aChildren(-1), aRows, nCount, iLayer)
    End If
    iLayer = iLayer - 1
    ' 当前节点没有子节点或已经访问过，退回到上一节点，层数 -1
    ' 当由兄弟节点返回时，也会 -1，故在访问兄弟节点需 +1
    If Not IsEmpty(aChildren(0)) And aChildren(0) > 1 Then
        ' 有兄弟节点，向右走
        iLayer = iLayer + 1
        Call GetChildrenFromBinaryTree(aChildren(0), aRows, nCount, iLayer)
    End If
End Sub
[/code]

aoyq2007

very good！thanks a lot.

hai167

不错，记号学习。

zengxp

标记。---仔细读会很有帮助

redsuc

感谢Excel home,感谢home中的你。
留记学习。

slg36

先收藏，再学习

lee1892

堆（Heap）、二叉堆（Binary Heap）、优先队列（Priority Queue）

堆 是一种基于 树形 的数据结构并且满足堆的特征：即如果 节点甲 是 节点乙 的父节点，那么 甲 和 乙 的顺序满足该堆的特定顺序。比如 一个最大堆（Max Heap）的父节点总是比其子节点大（或等），而一个最小堆（Min Heap）则反之。如下图：


可以注意到，对于一个堆进行有序遍历是不适宜的，上述堆的节点间关系不含有兄弟节点间关系以及邻近节点间关系。

子节点的数量可依据不同的堆设置，最为常见的是 2 个子节点，被称之为 二叉堆（Binary Heap），其它还有：二项堆（Binomial Heap）、斐波那契堆（Fibonacci Heap）等。

堆 最为普遍的应用是用来维护一个 优先队列，即无论是添加、删除还是更改堆中的某个元素，堆顶元素（根节点）总是 最大 或 最小 元素。

二叉堆：

二叉堆的两个基本特性：

1、二叉堆是一个完全二叉树，即新加元素总是添加在树的最底层从左到右的第一个空位上，或就堆的形状而言，仅在最底层的右侧可能存在空位。
2、满足堆的基本特征，即父节点总是不小于子节点（最大二叉堆）或是不大于子节点（最小二叉堆）。

两个基本操作：

插入（或添加）
1、添加新元素至堆底
2、比较该元素与其父节点，如果符合堆的顺序，则结束
3、如果不符合，则该元素与其父节点交换，重复第 2 步操作

删除（或提取堆顶）
1、将堆底元素置于被删除的元素位置（如为提取堆顶，则置于堆顶）
2、比较该元素与其子节点，如果符合堆的顺序，则结束
3、如果不符合，则与其中一个子节点交换，重复第 2 步操作（最大二叉堆中与大的子节点交换，最小二叉堆中与小的子节点交换）

二叉堆的实现：

通常使用数组来实现二叉堆。由于二叉堆是一个完全二叉树，所以不需要额外的空间来保存子节点或父节点的地址。比如：
1、以 0 开始的数组中，节点 i 的两个子节点的下标分别为：2i+ 1 和 2i + 2；而其父节点的下标为：Int((i - 1) / 2)
2、以 1 开始的数组中，节点 i 的两个子节点的下标分别为：2i 和 2i + 1；而其父节点的下标为：Int(i / 2)

1 楼附件，演示了一个用类代码实现的二叉堆，同时也体现了在前文中将类归为一种特殊的数据类型的原因。

lee1892

二叉堆的 类 代码实现
[code=vb]
' ====================================================================
'                         二叉堆的 类 实现演示
'                                               By Lee1892, 2013.01.14
' --------------------------------------------------------------------
' 属性：
'     HeapType       最大/最小堆，允许设定一次，可读写
'     Count          元素数量，只读
'     Item          （参数：元素序号）返回元素值
'     HeapTop        返回堆顶元素值
'     AllData        返回全部元素数组
' --------------------------------------------------------------------
' 方法：
'     Add            添加元素，返回该元素在堆中的位置
'     ExtracTop      返回并删除堆顶元素
'     DeleteByIndex （参数：元素序号）删除元素
'     ModifyByIndex （参数：元素序号）更改元素值
' ====================================================================
Option Explicit

Public Enum HEAP_TYPE
    bhMax = -1
    bhMin = 0
End Enum
Private Const lngStep = 100
Private arrData() As Variant
Private ehtHeapType As HEAP_TYPE
Private lngCount As Long
Private blnTypeSetted As Boolean
Private lngLength As Long

Public Property Let HeapType(ByVal eHeapType As HEAP_TYPE)
    If Not blnTypeSetted Then
        ehtHeapType = eHeapType
    Else
        Err.Raise 10000, "Binary Heap Class", _
                         "Heap type can only be set once." & vbCrLf & _
                         "This Binary Heap Class has been set as " & _
                         IIf(ehtHeapType, "Max. Heap", "Min. Heap")
    End If
End Property
Public Property Get HeapType() As HEAP_TYPE
    HeapType = ehtHeapType
End Property

Public Property Get Count() As Long
    Count = lngCount
End Property

Public Property Get Item(ByVal nIndex As Long) As Variant
    If nIndex < 1 Or nIndex > lngCount Then
        Err.Raise 10002, "Binary Heap Class", "Out of range."
        Exit Sub
    End If
    Item = arrData(nIndex)
End Property

Public Property Get HeapTop() As Variant
    If Not IsEmpty(arrData(1)) Then
        HeapTop = arrData(1)
    Else
        Err.Raise 10001, "Binary Heap Class", "The heap top is empty!"
    End If
End Property

Public Property Get AllData() As Variant
    Dim aOutput() As Variant
    If lngCount = 0 Then AllData = Array(): Exit Sub
    aOutput = arrData
    ReDim Preserve aOutput(1 To lngCount)
    AllData = aOutput
End Property

Private Sub Class_Initialize()
    ReDim arrData(1 To lngStep)
    blnTypeSetted = False
    lngCount = 0
    lngLength = 1
End Sub

Private Sub Class_Terminate()
    Erase arrData
End Sub

Public Function Add(ByVal vItem As Variant) As Long
    Dim nIndex As Long
    lngCount = lngCount + 1
    If lngCount > lngLength * lngStep Then
        lngLength = lngLength + 1
        ReDim Preserve arrData(1 To lngLength * lngStep)
    End If
    arrData(lngCount) = vItem
    Call UpHeap(lngCount, nIndex)
    Add = nIndex
End Function

Public Function ExtractTop() As Variant
    If IsEmpty(arrData(1)) Then
        Err.Raise 10001, "Binary Heap Class", "The heap top is empty!"
        Exit Function
    End If
    ExtractTop = arrData(1)
    If lngCount = 1 Then
        ReDim arrData(1 To lngStep)
        lngCount = lngCount - 1
    Else
        arrData(1) = arrData(lngCount)
        lngCount = lngCount - 1
        Call MaxHeapify(1)
    End If
End Function

Public Function DeleteByIndex(ByVal nIndex As Long) As Boolean
    If nIndex > lngCount Or nIndex < 1 Then
        DeleteByIndex = False
        Exit Function
    End If
    arrData(nIndex) = arrData(lngCount)
    lngCount = lngCount - 1
    Call MaxHeapify(nIndex)
    DeleteByIndex = True
End Function

Public Function ModifyByIndex(ByVal nIndex As Long, ByVal vValue As Variant) As Boolean
    If nIndex > lngCount Or nIndex < 1 Then
        ModifyByIndex = False
        Exit Function
    End If
    ModifyByIndex = True
    If vValue = arrData(nIndex) Then Exit Function
    If (ehtHeapType = bhMax And vValue > arrData(nIndex)) Or _
       (ehtHeapType = bhMin And vValue < arrData(nIndex)) Then
        arrData(nIndex) = vValue
        Call UpHeap(nIndex)
    Else
        arrData(nIndex) = vValue
        Call MaxHeapify(nIndex)
    End If
End Function

Private Sub UpHeap(ByVal nIndex As Long, Optional nReturn As Long)
    Dim vSwap As Variant, nParent As Long
    nReturn = nIndex
    If nIndex = 1 Then Exit Sub
    nParent = nIndex \ 2
    If (ehtHeapType = bhMax And arrData(nIndex) > arrData(nParent)) Or _
       (ehtHeapType = bhMin And arrData(nIndex) < arrData(nParent)) Then
        vSwap = arrData(nIndex): arrData(nIndex) = arrData(nParent): arrData(nParent) = vSwap
        nReturn = nParent
        Call UpHeap(nParent)
    End If
End Sub

Private Sub MaxHeapify(ByVal nIndex As Long)
    Dim vSwap As Variant, nChild As Long
    If 2 * nIndex > lngCount Then Exit Sub
    If 2 * nIndex = lngCount Then
        nChild = 2 * nIndex
    ElseIf (ehtHeapType = bhMax And arrData(2 * nIndex) > arrData(2 * nIndex + 1)) Or _
           (ehtHeapType = bhMin And arrData(2 * nIndex) < arrData(2 * nIndex + 1)) Then
        nChild = 2 * nIndex
    Else
        nChild = 2 * nIndex + 1
    End If
    If (ehtHeapType = bhMax And arrData(nChild) > arrData(nIndex)) Or _
       (ehtHeapType = bhMin And arrData(nChild) < arrData(nIndex)) Then
        vSwap = arrData(nIndex): arrData(nIndex) = arrData(nChild): arrData(nChild) = vSwap
        Call MaxHeapify(nChild)
    End If
End Sub
[/code]

zengxp

太高深了，基本上看不懂啊。。{:soso_e127:}