VBA编程技巧之不用字典、集合实现联动菜单及简易字典功能的实现

lee1892 · 发表于 2014-12-9 16:37

本帖最后由 lee1892 于 2014-12-10 14:30 编辑

本贴附件：

不用字典、集合实现联动菜单及简易字典功能的实现 by Lee1892.rar (18.43 KB, 下载次数: 375)
修订附件：

不用字典、集合实现联动菜单及简易字典功能的实现 v1.0 by Lee1892.rar (23.17 KB, 下载次数: 629)

坛子里介绍如何实现联动菜单的贴子不少了，我自己就写过蛮多的，现在回头看以前的那个字典套字典的贴子都犯晕

本贴附件效果：
不用字典.gif

这里介绍一个使用简易字典功能实现的办法，采用的是除余法，字典功能的实现只是简单的一个函数，如下：

Private lngCount As Long ' 字典项目计数
Private arrKeys() As String ' 字典的关键字数组, 树结构中节点的由根节点开始的全路径
Private arrItems() As String ' 字典的项目数组, 树结构中该节点下的子节点名以逗号连接
Private lngCollision As Long ' 哈希表位置碰撞计数
Private lngTableSize As Long ' 哈希表大小
Private arrHashTable() As Long ' 哈希表数组, 下标为关键字计算所得的值, 值为该关键字对应的序号
Private Function GetIndex&(sPath$, Optional IsNewItem As Boolean = False)
Rem IsNewItem = True, 返回新项目在哈希表中的位置
Rem IsNewItem = False, 返回字符串对应的序号
Dim i&, aStr() As Byte, nStrKey&, nHashInd&
Const LNG_SEED_1& = 113
Const LNG_SEED_2& = 601
Const LNG_SEED_3& = 71
Const LNG_SEED_4& = 137
Const LNG_MODE& = 470011
Const LNG_PRIME& = 3571
Rem 计算字符串特征值
aStr = sPath
For i = 0 To 2 * Len(sPath) - 1 Step 2
nStrKey = (nStrKey * LNG_SEED_1 + CLng(aStr(i)) * LNG_SEED_2) Mod LNG_MODE
nStrKey = (nStrKey * LNG_SEED_3 + CLng(aStr(i + 1)) * LNG_SEED_4) Mod LNG_MODE
Next
Rem 由特征值计算哈希表中位置
nHashInd = nStrKey * LNG_PRIME Mod lngTableSize + 1 ' 哈希表数组下标由 1 开始
Rem 处理哈希表位置碰撞
Do
Rem 如果该位置未被占用，则如为查询新项目在哈希表中的位置则返回该位置否则返回零
If arrHashTable(nHashInd) = 0 Then GetIndex = IIf(IsNewItem, nHashInd, 0): Exit Do
If IsNewItem Then
Rem 对哈希表位置碰撞计数
lngCollision = lngCollision + 1
Debug.Print Format(lngCollision, "000: ");
Debug.Print sPath
Debug.Print String(5, " "); arrKeys(arrHashTable(nHashInd))
Else
Rem 对比该位置对应的关键字是否与输入字符串相同，相同则返回哈希表中该位置的值
If Len(sPath) = Len(arrKeys(arrHashTable(nHashInd))) Then
If sPath = arrKeys(arrHashTable(nHashInd)) Then GetIndex = arrHashTable(nHashInd): Exit Do
End If
End If
Rem 产生哈希表位置碰撞，位置向后挪一位查询
nHashInd = nHashInd + 1
If nHashInd > lngTableSize Then nHashInd = 1
Loop
End Function

复制代码

laojiu369 · 发表于 2014-12-9 17:10

感谢分享，下载学习了！

lee1892 · 发表于 2014-12-10 14:29

修订了字典功能的实现方法，添加了新附件，并加了注释。

字典功能实现的函数放在顶楼了。

1.0版的读取数据初始化过程为：

Private Sub Initialize()
Dim aData, i&, j&, k&, nRows&, nCols&, nInd&, nParent&
Dim sNode$, sPath$, nHashInd&
Rem 读取原始数据
aData = shtData.Range("A1").CurrentRegion
nRows = UBound(aData): nCols = UBound(aData, 2)
lngLayer = nCols ' 总层数等于列数
lngCount = 0 ' 字典项目计数初值
lngCollision = 0 ' 哈希表位置碰撞次数初值
ReDim arrItems(-1 To nRows * nCols) ' 预设字典项目数组， -1 为根节点，0 留空
ReDim arrKeys(-1 To nRows * nCols) ' 预设字典关键字数组，-1 为根节点，0 留空
lngTableSize = nRows * nCols * 2 ' 哈希表大小为预设数组的 2 倍
ReDim arrHashTable(1 To lngTableSize) ' 初始化哈希表
arrHashTable(GetIndex("-", True)) = -1 ' 根节点命名并添加到哈希表中
arrKeys(-1) = "-" ' 添加根节点关键字
Rem 数据特征为每行中各列由前到后为树结构中的完整节点路径
Rem 按先列后行扫描, 即列循环在行循环内部
For i = 2 To nRows
sPath = "" ' 路径初值为空
nParent = -1 ' 父节点初值为根节点
For j = 1 To nCols
sNode = aData(i, j) ' 节点名
sPath = sPath & "-" & sNode ' 节点全路径
nInd = GetIndex(sPath) ' 获得以全路径为关键字的序号
If nInd = 0 Then
Rem 该关键字不在哈希表中
lngCount = lngCount + 1 ' 字典计数
nInd = lngCount ' 关键字序号
arrHashTable(GetIndex(sPath, True)) = nInd
' 添加该序号到哈希表中
arrKeys(nInd) = sPath ' 添加到关键字数组
Rem 将当前节点名添加到父节点的项目数组中
If Len(arrItems(nParent)) > 0 Then
arrItems(nParent) = arrItems(nParent) & "," & sNode
Else
arrItems(nParent) = sNode
End If
End If
nParent = nInd ' 下一列的父节点为当前节点
Next
Next
ReDim Preserve arrItems(-1 To lngCount)
ReDim Preserve arrKeys(-1 To lngCount)
End Sub

复制代码

aman1516 · 发表于 2014-12-11 22:03

向老师学习，应用实例对初学者实在是太有用了。还加了注释，谢谢分享！

bowei · 发表于 2015-7-19 10:57

正在學習中，謝謝分享^^

gnixay · 发表于 2016-12-1 14:28

努力学习楼主的思路

yzgx201 · 发表于 2018-3-10 18:10

学习，谢谢

gjxk999 · 发表于 2018-11-25 10:18

有创意，谢谢分享。

bjh187 · 发表于 2019-4-19 15:40

谢谢，下来学习

用心修炼 · 发表于 2019-8-1 08:55

先打卡，后面慢慢啃，感觉有点难懂

		自动登录	找回密码
密码			免费注册

[原创] VBA编程技巧之不用字典、集合实现联动菜单及简易字典功能的实现

评分

评分

[原创] VBA编程技巧 之 不用字典、集合实现联动菜单 及 简易字典功能的实现

评分

评分

[原创] VBA编程技巧之不用字典、集合实现联动菜单及简易字典功能的实现