如何在VBA中以400万个数组循环时减少时间成本？

Question

我需要使用VBA执行'vlookup'功能.我需要从包含460万条记录的访问数据库中查找数据.

Private Sub connectDB()
 Dim sqlstr As String
 Dim mydata As String
 Dim t, d, conn, rst, mydata
 Dim arr, arr1
 t = Timer
 Set d = CreateObject("scripting.dictionary")
 Set conn = CreateObject("ADODB.Connection")
 Set rst = CreateObject("ADODB.Recordset")
 mydata = "mydatabase"
 strconn = "Provider = Microsoft.ACE.OLEDB.16.0; Data Source = " & mydata
 sqlstr = "select Tracking, MAWB from total"
 rst.Open sqlstr, strconn, 3, 2
 arr1 = Array("Tracking", "MAWB")
 arr = rst.GetRows(-1, 1, arr1)
STOP
#Above cost 1mins
 For i = 0 To UBound(arr, 2)
    d(arr(0, i)) = arr(1, i)
Next
STOP
#Put data into dictionary always costs me 20 mins

上述程序总是花费我大约20分钟.其中大部分用于将数据放入字典中

无论如何要减少时间成本？

Answer 1

您可以通过实现自己的哈希表/字典来显着减少查找时间.

这是一个在5秒内索引4百万个数组的示例:

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

Sub Example()
  Dim data(), slots() As Long, i As Long

  ' generate some records '

  ReDim data(0 To 1, 0 To 4000000)
  For i = 0 To UBound(data, 2)
    data(0, i) = CStr(i)
  Next

  ' index all the keys from column 1 '

  MapKeys slots, data, column:=0

  ' lookup a key in column 1 '

  i = IndexOfKey(slots, data, column:=0, key:="4876")

  If i >= 0 Then
    Debug.Print "Found at index " & i
  Else
    Debug.Print "Missing"
  End If

End Sub


Public Sub MapKeys(slots() As Long, data(), column As Long)
  Dim bucketsCount&, key$, r&, i&, s&, h&      
  bucketsCount = UBound(data, 2) * 0.9   ' n * load factor '
  ReDim slots(0 To UBound(data, 2) + bucketsCount)

  For r = 0 To UBound(data, 2) ' each record '
    key = data(column, r)
    h = RtlComputeCrc32(0, StrPtr(key), LenB(key)) And &H7FFFFFF  ' get hash '
    s = UBound(slots) - (h Mod bucketsCount)                      ' get slot '
    Do
      i = slots(s) - 1& ' get index (base 0) '

      If i >= 0& Then  ' if index for hash '
        If data(column, i) = data(column, r) Then Exit Do  ' if key present, handle next record '
      Else
        slots(s) = r + 1&  ' add index (base 1) '
        Exit Do
      End If

      s = i  ' collision, index points to the next slot '
    Loop
  Next
End Sub

Public Function IndexOfKey(slots() As Long, data(), column As Long, key As String) As Long
  Dim h&, s&, i&
  h = RtlComputeCrc32(0, StrPtr(key), LenB(key)) And &H7FFFFFF    ' get hash  '
  s = UBound(slots) - (h Mod (UBound(slots) - UBound(data, 2)))   ' get slot  '
  i = slots(s) - 1&                                               ' get index (base 0) '

  Do While i >= 0&
    If data(column, i) = key Then Exit Do  ' break if same key '
    i = slots(i) - 1&                      ' collision, index points to the next slot '
  Loop

  IndexOfKey = i
End Function