Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 3657|回复: 3

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

[复制链接]
发表于 2017-12-4 12:53 | 显示全部楼层 |阅读模式
之前遇到一个情况,要把400万的一个数组导进字典进行匹配,耗时要20分钟了。后来stackoverflow上一个哥们提供了一个类模块,导入400万数据再匹配只要花几分钟,比自带的字典要强大很多。
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "JObject"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = False
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = True
  10. Attribute VB_Description = "Represents a collection of keys and items."
  11. '
  12. ' Version: 2017/08/20
  13. '
  14. ' Data structure to map keys to values with a minimum cost.
  15. '
  16. ' Key features :
  17. '  * Provides introspection on each key/value in the debug view.
  18. '  * Supports keys as string only.
  19. '  * Raises an error if the key is missing, unless a default value is provided.
  20. '  * Preserves the insertion order.
  21. '  * Supports access to keys and items by index.
  22. '  * Supports shallow copy.
  23. '  * Performs better than Scripting.Dictionary or VBA.Collection, especially on large sets.
  24. '
  25. ' Usage:
  26. '
  27. '  Dim dict As New JObject
  28. '
  29. '  ' Set an the capacity to improve the processing with large sets '
  30. '  dict.SetCapacity 2000000
  31. '
  32. '  ' Add a key/item and raise an error if the key is already present '
  33. '  dict.Add "a", 1
  34. '
  35. '  ' Set a key/item. Overwrites the item if the key is already present '
  36. '  dict("a") = 2
  37. '
  38. '  ' Get an item or raise an error if the key is not present '
  39. '  Debug.Print dict("a")
  40. '
  41. '  ' Get an item or a default item if the key is not present '
  42. '  Debug.Print dict("b", Default:=3)
  43. '
  44. '  ' Find out if a key exists '
  45. '  Debug.Print dict.Exists("a")
  46. '
  47. '  ' Get an item only if present '
  48. '  Dim value
  49. '  If dict.TryGet("a", value) Then Debug.Print value
  50. '
  51. '  ' Add an item only if it's not already present '
  52. '  If dict.TryAdd("a", 5) Then Debug.Print "Successfuly added"
  53. '  If Not dict.TryAdd("a", 5) Then Debug.Print "Key already present"
  54. '
  55. '  ' Iterate the keys/items (Base 1 index) '
  56. '  For i = 1 To dict.Count
  57. '    Debug.Print dict.Keys(i), dict.Items(i)
  58. '  Next
  59. '
  60. '

  61. Option Explicit
  62. Option Base 1

  63. Private Declare PtrSafe Function hash Lib "ntdll.dll" Alias "RtlComputeCrc32" ( _
  64.   ByVal start As Long, ByVal data As LongPtr, ByVal size As Long) As Long

  65. Private Type TFields
  66.   Bound As Long       ' Index of the last entry '
  67.   Keys() As Variant   ' Ordered keys [0..Bound, free space] '
  68.   Items() As Variant  ' Ordered items [0..Bound, free space] '
  69.   Hashs() As Long     ' Ordered keys's hash on 31 bits where 0 = no entr '
  70.   slots() As Long     ' Indexes of the next entry '
  71. End Type

  72. Private this As TFields

  73. Private Sub Class_Initialize()
  74.   SetCapacity 3
  75. End Sub

  76. Public Sub SetCapacity(n As Long)
  77. Attribute SetCapacity.VB_Description = "Set the capacity."
  78.   Dim i&, s&
  79.   ReDim Preserve this.Hashs(n), this.Keys(n), this.Items(n)
  80.   ReDim this.slots(n + n)
  81.   
  82.   For i = 1 To this.Bound
  83.     s = UBound(this.slots) - this.Hashs(i) Mod n  ' get the slot '
  84.    
  85.     Do While this.slots(s)    ' lookup an empty slot '
  86.       s = this.slots(s)
  87.     Loop
  88.    
  89.     this.slots(s) = i   ' empty slot gets the index '
  90.   Next
  91. End Sub

  92. Public Function Clone() As JObject
  93. Attribute Clone.VB_Description = "Clone this dictionary in a new instance (shallow copy)."
  94.   Set Clone = New JObject
  95.   Clone.x_load this
  96. End Function

  97. Friend Sub x_load(dict As TFields)
  98.   this = dict
  99. End Sub

  100. Public Sub RemoveAll()
  101. Attribute RemoveAll.VB_Description = "Removes all keys and items."
  102.   Erase this.Keys, this.Items, this.Hashs, this.slots
  103.   Class_Initialize
  104. End Sub

  105. Public Function Count() As Long
  106. Attribute Count.VB_Description = "Gets the number of items."
  107.   Count = this.Bound
  108. End Function

  109. Public Function Keys(Optional Index As Long)
  110. Attribute Keys.VB_Description = "Returns an array of keys or the key at index (Base 1)."
  111.   x_get this.Keys, Index, Keys
  112. End Function

  113. Public Function Items(Optional Index As Long)
  114. Attribute Items.VB_Description = "Returns an array of items or the item at index (Base 1)."
  115.   x_get this.Items, Index, Items
  116. End Function

  117. Private Sub x_get(source(), i&, output)
  118.   If i Then              ' return the value at index '
  119.     If i > this.Bound Then Err.Raise 9
  120.     If VBA.IsObject(source(i)) Then Set output = source(i) Else output = source(i)
  121.   ElseIf this.Bound Then ' return all the values in a base1 array '
  122.     output = source
  123.     ReDim Preserve output(this.Bound)
  124.   Else                   ' return an empty base1 array '
  125.     output = Array()
  126.   End If
  127. End Sub

  128. Public Property Get Item(key As String, Optional default)
  129. 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."
  130. Attribute Item.VB_UserMemId = 0
  131.   Dim i&
  132.   If x_try_find(key, i) Then
  133.     If VBA.IsObject(this.Items(i)) Then Set Item = this.Items(i) Else Item = this.Items(i)
  134.   Else
  135.     If VBA.IsMissing(default) Then Err.Raise 9, , "Key not found: " & CStr(key)
  136.     If VBA.IsObject(default) Then Set Item = default Else Item = default
  137.   End If
  138. End Property

  139. Public Property Let Item(key As String, Optional default, Item)
  140.   Dim i&
  141.   If x_try_add(key, Item, i) Then Else this.Items(i) = Item
  142. End Property

  143. Public Property Set Item(key As String, Optional default, Item)
  144.   Dim i&
  145.   If x_try_add(key, Item, i) Then Else Set this.Items(i) = Item
  146. End Property

  147. Public Function Exists(key As String) As Long
  148. Attribute Exists.VB_Description = "Returns true if the key is present, false otherwise."
  149.   Exists = x_try_find(key, 0)
  150. End Function

  151. Public Function IndexOf(key As String) As Long
  152. Attribute IndexOf.VB_Description = "Returns the index of the key/item."
  153.   x_try_find key, IndexOf
  154. End Function

  155. Public Sub Add(key As String, Item)
  156. Attribute Add.VB_Description = "Adds the key/item to the dictionary. Raises error 457 if the key is already associated."
  157.   If x_try_add(key, Item, 0) Then Else Err.Raise 457, , "Key already associated: " & CStr(key)
  158. End Sub

  159. Public Function TryGet(key As String, ByRef Item) As Boolean
  160. Attribute TryGet.VB_Description = "Returns True if the key is present with the item in the last argument."
  161.   Dim i&
  162.   If x_try_find(key, i) Then Else Exit Function
  163.   If VBA.IsObject(this.Items(i)) Then Set Item = this.Items(i) Else Item = this.Items(i)
  164.   TryGet = True
  165. End Function

  166. Public Function TryAdd(key As String, Item) As Boolean
  167. Attribute TryAdd.VB_Description = "Returns True if were successfully added."
  168.   TryAdd = x_try_add(key, Item, 0)
  169. End Function

  170. Public Function NewEnum() As IUnknown
  171. Attribute NewEnum.VB_UserMemId = -4
  172.   Static obj As Collection
  173.   Set obj = New Collection

  174.   Dim i&, n&
  175.   If this.Bound > 256 Then n = 256 Else n = this.Bound
  176.   
  177.   For i = 1 To n
  178.     If this.Hashs(i) Then obj.Add VBA.Array(this.Keys(i), this.Items(i))
  179.   Next

  180.   Set NewEnum = obj.[_NewEnum]
  181. End Function

  182. Private Function x_try_find(key As String, i&) As Boolean
  183.   Dim h&
  184.   
  185.   h = hash(0, StrPtr(key), LenB(key)) And &H7FFFFFFF
  186.   i = this.slots(UBound(this.slots) - h Mod UBound(this.Hashs))
  187.   Do
  188.     If i Then Else Exit Function
  189.     If this.Hashs(i) = h Then If StrComp(key, this.Keys(i), vbBinaryCompare) Then Else Exit Do
  190.     i = this.slots(i)  ' try next slot '
  191.   Loop
  192.   
  193.   x_try_find = True
  194. End Function

  195. Private Function x_try_add(key As String, Item, i&) As Boolean
  196.   Dim h&, s&
  197.   If this.Bound = UBound(this.Keys) Then SetCapacity this.Bound * 11 \ 6
  198.   
  199.   h = hash(0, StrPtr(key), LenB(key)) And &H7FFFFFFF
  200.   s = UBound(this.slots) - h Mod UBound(this.Hashs)  ' slot from the second half '
  201.   Do
  202.     i = this.slots(s)  ' get index '
  203.     If i Then Else Exit Do
  204.     If this.Hashs(i) = h Then If StrComp(key, this.Keys(i), vbBinaryCompare) Then Else Exit Function
  205.     s = i  ' try next slot '
  206.   Loop
  207.   
  208.   i = this.Bound + 1
  209.   this.Bound = i
  210.   this.slots(s) = i
  211.   this.Hashs(i) = h
  212.   this.Keys(i) = key
  213.   If VBA.IsObject(Item) Then Set this.Items(i) = Item Else this.Items(i) = Item
  214.   x_try_add = True
  215.   
  216. End Function
复制代码
复制进记事本之后,保存为"JObject.cls"
再进行导入操作
具体使用如下
  1. dim d as new Jobject '声明dict
  2. d.SetCapacity 5000000 '设置字典的大小
复制代码
之后的添加key和item等和正常字典一样目前在用数组循环添加key和item时需要这样,只支持字符串类型
  1. d.add cstr(arr(i,1)),cstr(arr(i,2))
复制代码


评分

参与人数 1学分 +3 收起 理由
砂海 + 3

查看全部评分

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2017-12-4 14:44 | 显示全部楼层
回复

使用道具 举报

 楼主| 发表于 2017-12-4 15:32 | 显示全部楼层
补一下附件 Sheet1.rar (17.19 KB, 下载次数: 58)
回复

使用道具 举报

发表于 2020-6-19 17:25 | 显示全部楼层
谢谢分享
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 06:56 , Processed in 0.293140 second(s), 13 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表