分享一个VBA字典的加强版

zhangzhang21 · 发表于 2017-12-4 12:39

本帖最后由 zhangzhang21 于 2017-12-4 12:42 编辑

之前遇到一个情况，要把400万的一个数组导进字典进行匹配，耗时要20分钟了。后来stackoverflow上一个哥们提供了一个类模块，导入400万数据再匹配只要花几分钟，比自带的字典要强大很多。

VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "JObject"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Description = "Represents a collection of keys and items."
'
' Version: 2017/08/20
'
' Data structure to map keys to values with a minimum cost.
'
' Key features :
' * Provides introspection on each key/value in the debug view.
' * Supports keys as string only.
' * Raises an error if the key is missing, unless a default value is provided.
' * Preserves the insertion order.
' * Supports access to keys and items by index.
' * Supports shallow copy.
' * Performs better than Scripting.Dictionary or VBA.Collection, especially on large sets.
'
' Usage:
'
' Dim dict As New JObject
'
' ' Set an the capacity to improve the processing with large sets '
' dict.SetCapacity 2000000
'
' ' Add a key/item and raise an error if the key is already present '
' dict.Add "a", 1
'
' ' Set a key/item. Overwrites the item if the key is already present '
' dict("a") = 2
'
' ' Get an item or raise an error if the key is not present '
' Debug.Print dict("a")
'
' ' Get an item or a default item if the key is not present '
' Debug.Print dict("b", Default:=3)
'
' ' Find out if a key exists '
' Debug.Print dict.Exists("a")
'
' ' Get an item only if present '
' Dim value
' If dict.TryGet("a", value) Then Debug.Print value
'
' ' Add an item only if it's not already present '
' If dict.TryAdd("a", 5) Then Debug.Print "Successfuly added"
' If Not dict.TryAdd("a", 5) Then Debug.Print "Key already present"
'
' ' Iterate the keys/items (Base 1 index) '
' For i = 1 To dict.Count
' Debug.Print dict.Keys(i), dict.Items(i)
' Next
'
'
Option Explicit
Option Base 1
Private Declare PtrSafe Function hash Lib "ntdll.dll" Alias "RtlComputeCrc32" ( _
ByVal start As Long, ByVal data As LongPtr, ByVal size As Long) As Long
Private Type TFields
Bound As Long ' Index of the last entry '
Keys() As Variant ' Ordered keys [0..Bound, free space] '
Items() As Variant ' Ordered items [0..Bound, free space] '
Hashs() As Long ' Ordered keys's hash on 31 bits where 0 = no entr '
slots() As Long ' Indexes of the next entry '
End Type
Private this As TFields
Private Sub Class_Initialize()
SetCapacity 3
End Sub
Public Sub SetCapacity(n As Long)
Attribute SetCapacity.VB_Description = "Set the capacity."
Dim i&, s&
ReDim Preserve this.Hashs(n), this.Keys(n), this.Items(n)
ReDim this.slots(n + n)
For i = 1 To this.Bound
s = UBound(this.slots) - this.Hashs(i) Mod n ' get the slot '
Do While this.slots(s) ' lookup an empty slot '
s = this.slots(s)
Loop
this.slots(s) = i ' empty slot gets the index '
Next
End Sub
Public Function Clone() As JObject
Attribute Clone.VB_Description = "Clone this dictionary in a new instance (shallow copy)."
Set Clone = New JObject
Clone.x_load this
End Function
Friend Sub x_load(dict As TFields)
this = dict
End Sub
Public Sub RemoveAll()
Attribute RemoveAll.VB_Description = "Removes all keys and items."
Erase this.Keys, this.Items, this.Hashs, this.slots
Class_Initialize
End Sub
Public Function Count() As Long
Attribute Count.VB_Description = "Gets the number of items."
Count = this.Bound
End Function
Public Function Keys(Optional Index As Long)
Attribute Keys.VB_Description = "Returns an array of keys or the key at index (Base 1)."
x_get this.Keys, Index, Keys
End Function
Public Function Items(Optional Index As Long)
Attribute Items.VB_Description = "Returns an array of items or the item at index (Base 1)."
x_get this.Items, Index, Items
End Function
Private Sub x_get(source(), i&, output)
If i Then ' return the value at index '
If i > this.Bound Then Err.Raise 9
If VBA.IsObject(source(i)) Then Set output = source(i) Else output = source(i)
ElseIf this.Bound Then ' return all the values in a base1 array '
output = source
ReDim Preserve output(this.Bound)
Else ' return an empty base1 array '
output = Array()
End If
End Sub
Public Property Get Item(key As String, Optional default)
Attribute Item.VB_Description = "Gets or sets the item. Raises error 422 with get if the key is missing and the default value not provided."
Attribute Item.VB_UserMemId = 0
Dim i&
If x_try_find(key, i) Then
If VBA.IsObject(this.Items(i)) Then Set Item = this.Items(i) Else Item = this.Items(i)
Else
If VBA.IsMissing(default) Then Err.Raise 9, , "Key not found: " & CStr(key)
If VBA.IsObject(default) Then Set Item = default Else Item = default
End If
End Property
Public Property Let Item(key As String, Optional default, Item)
Dim i&
If x_try_add(key, Item, i) Then Else this.Items(i) = Item
End Property
Public Property Set Item(key As String, Optional default, Item)
Dim i&
If x_try_add(key, Item, i) Then Else Set this.Items(i) = Item
End Property
Public Function Exists(key As String) As Long
Attribute Exists.VB_Description = "Returns true if the key is present, false otherwise."
Exists = x_try_find(key, 0)
End Function
Public Function IndexOf(key As String) As Long
Attribute IndexOf.VB_Description = "Returns the index of the key/item."
x_try_find key, IndexOf
End Function
Public Sub Add(key As String, Item)
Attribute Add.VB_Description = "Adds the key/item to the dictionary. Raises error 457 if the key is already associated."
If x_try_add(key, Item, 0) Then Else Err.Raise 457, , "Key already associated: " & CStr(key)
End Sub
Public Function TryGet(key As String, ByRef Item) As Boolean
Attribute TryGet.VB_Description = "Returns True if the key is present with the item in the last argument."
Dim i&
If x_try_find(key, i) Then Else Exit Function
If VBA.IsObject(this.Items(i)) Then Set Item = this.Items(i) Else Item = this.Items(i)
TryGet = True
End Function
Public Function TryAdd(key As String, Item) As Boolean
Attribute TryAdd.VB_Description = "Returns True if were successfully added."
TryAdd = x_try_add(key, Item, 0)
End Function
Public Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Static obj As Collection
Set obj = New Collection
Dim i&, n&
If this.Bound > 256 Then n = 256 Else n = this.Bound
For i = 1 To n
If this.Hashs(i) Then obj.Add VBA.Array(this.Keys(i), this.Items(i))
Next
Set NewEnum = obj.[_NewEnum]
End Function
Private Function x_try_find(key As String, i&) As Boolean
Dim h&
h = hash(0, StrPtr(key), LenB(key)) And &H7FFFFFFF
i = this.slots(UBound(this.slots) - h Mod UBound(this.Hashs))
Do
If i Then Else Exit Function
If this.Hashs(i) = h Then If StrComp(key, this.Keys(i), vbBinaryCompare) Then Else Exit Do
i = this.slots(i) ' try next slot '
Loop
x_try_find = True
End Function
Private Function x_try_add(key As String, Item, i&) As Boolean
Dim h&, s&
If this.Bound = UBound(this.Keys) Then SetCapacity this.Bound * 11 \ 6
h = hash(0, StrPtr(key), LenB(key)) And &H7FFFFFFF
s = UBound(this.slots) - h Mod UBound(this.Hashs) ' slot from the second half '
Do
i = this.slots(s) ' get index '
If i Then Else Exit Do
If this.Hashs(i) = h Then If StrComp(key, this.Keys(i), vbBinaryCompare) Then Else Exit Function
s = i ' try next slot '
Loop
i = this.Bound + 1
this.Bound = i
this.slots(s) = i
this.Hashs(i) = h
this.Keys(i) = key
If VBA.IsObject(Item) Then Set this.Items(i) = Item Else this.Items(i) = Item
x_try_add = True
End Function

复制代码

复制进记事本之后，保存为"JObject.cls"
再进行导入操作
具体使用如下

dim d as new Jobject '声明dict
d.SetCapacity 5000000 '设置字典的大小

复制代码

之后的添加key和item等和正常字典一样目前在用数组循环添加key和item时需要这样,只支持字符串类型

d.add cstr(arr(i,1)),cstr(arr(i,2))

复制代码

zhangzhang21 · 发表于 2017-12-4 12:48

小数据量表现如何没有测试。
反正我用来对付70,80万的数据要比原来的字典快很多很多

fxl447098457 · 发表于 2017-12-4 13:40

感谢分享，先MARK下，有空再看看。。

huang1314wei · 发表于 2017-12-4 13:43

感谢分享，不过，如果几十万数据量再怎么快应该没有SQL快吧

zhangzhang21 · 发表于 2017-12-4 13:53

huang1314wei 发表于 2017-12-4 13:43
感谢分享，不过，如果几十万数据量再怎么快应该没有SQL快吧

肯定没有SQL快，他这个应该是自己建了个hash table，具体我反正也没怎么看懂
我是有40多个excel要去匹配，全弄进数据库里，再导出来excel就要不少时间了，所以这个字典还是比较适合我的

蓝桥玄霜 · 发表于 2017-12-4 14:08

第76和105句代码没有出现问题？

zhangzhang21 · 发表于 2017-12-4 14:19

蓝桥玄霜发表于 2017-12-4 14:08
第76和105句代码没有出现问题？

咱们论坛代码框的换行符好像不一样
https://gist.githubusercontent.c ... 10eee64/JObject.cls
复制这个里面的，到记事本，保存为“JObject.cls”
然后导入

zhangzhang21 · 发表于 2017-12-4 14:35

蓝桥玄霜发表于 2017-12-4 14:08
第76和105句代码没有出现问题？

论坛代码框里的换行符的问题

Sheet1.rar (17.78 KB, 下载次数: 94)

或者复制这个网址里面的到记事本，保存为“JObject.cls”再导入

https://gist.githubusercontent.com/florentbr/75cbc2b9ea4cddea72383adaa6c09be4/raw/0c91ba15b839611f4c2b46cd596a4f33b10eee64/JObject.cls

复制代码

zhangzhang21 · 发表于 2017-12-4 14:38

蓝桥玄霜发表于 2017-12-4 14:08
第76和105句代码没有出现问题？

好吧，回了好几次都要审核
应该是论坛代码框里换行符的问题

Sheet1.rar (17.78 KB, 下载次数: 104)

liuzq0306 · 发表于 2017-12-4 15:02

这么多数据量不用数据库，还用电子表格，我也觉得是神了。

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

[分享] 分享一个VBA字典的加强版

评分