Bảng băm / Mảng liên kết trong VBA

Question 1

Tôi dường như không thể tìm thấy tài liệu giải thích cách tạo bảng băm hoặc mảng kết hợp trong VBA. Nó thậm chí có thể?

Bạn có thể liên kết đến một bài báo hoặc tốt hơn là đăng mã?

Question 2

Tôi nghĩ rằng bạn đang tìm kiếm đối tượng Từ điển, được tìm thấy trong thư viện Thời gian chạy kịch bản của Microsoft. (Thêm tham chiếu vào dự án của bạn từ menu Công cụ ... Tham chiếu trong VBE.)

Nó hoạt động khá nhiều với bất kỳ giá trị đơn giản nào có thể phù hợp với một biến thể (Các phím không thể là mảng và việc cố gắng biến chúng thành đối tượng không có ý nghĩa nhiều. Hãy xem nhận xét từ @Nile bên dưới.):

Dim d As dictionary
Set d = New dictionary

d("x") = 42
d(42) = "forty-two"
d(CVErr(xlErrValue)) = "Excel #VALUE!"
Set d(101) = New Collection

Bạn cũng có thể sử dụng đối tượng VBA Collection nếu nhu cầu của bạn đơn giản hơn và bạn chỉ muốn các khóa chuỗi.

Tôi không biết liệu có thực sự băm trên bất kỳ thứ gì hay không, vì vậy bạn có thể muốn tìm hiểu sâu hơn nếu bạn cần hiệu suất giống như bảng băm. (CHỈNH SỬA: Scripting.Dictionary không sử dụng bảng băm bên trong.)

Question 3

Tôi đã sử dụng lớp HashTable của Francesco Balena vài lần trong quá khứ khi Bộ sưu tập hoặc Từ điển không phù hợp hoàn hảo và tôi chỉ cần một HashTable.

Question 4

Hãy thử sử dụng Đối tượng Từ điển hoặc Đối tượng Bộ sưu tập.

http://visualbasic.ittoolbox.com/documents/dictionary-object-vs-collection-object-12196

Question 5

Chúng ta bắt đầu ... chỉ cần sao chép mã vào một mô-đun, nó đã sẵn sàng để sử dụng

Private Type hashtable
    key As Variant
    value As Variant
End Type

Private GetErrMsg As String

Private Function CreateHashTable(htable() As hashtable) As Boolean
    GetErrMsg = ""
    On Error GoTo CreateErr
        ReDim htable(0)
        CreateHashTable = True
    Exit Function

CreateErr:
    CreateHashTable = False
    GetErrMsg = Err.Description
End Function

Private Function AddValue(htable() As hashtable, key As Variant, value As Variant) As Long
    GetErrMsg = ""
    On Error GoTo AddErr
        Dim idx As Long
        idx = UBound(htable) + 1

        Dim htVal As hashtable
        htVal.key = key
        htVal.value = value

        Dim i As Long
        For i = 1 To UBound(htable)
            If htable(i).key = key Then Err.Raise 9999, , "Key [" & CStr(key) & "] is not unique"
        Next i

        ReDim Preserve htable(idx)

        htable(idx) = htVal
        AddValue = idx
    Exit Function

AddErr:
    AddValue = 0
    GetErrMsg = Err.Description
End Function

Private Function RemoveValue(htable() As hashtable, key As Variant) As Boolean
    GetErrMsg = ""
    On Error GoTo RemoveErr

        Dim i As Long, idx As Long
        Dim htTemp() As hashtable
        idx = 0

        For i = 1 To UBound(htable)
            If htable(i).key <> key And IsEmpty(htable(i).key) = False Then
                ReDim Preserve htTemp(idx)
                AddValue htTemp, htable(i).key, htable(i).value
                idx = idx + 1
            End If
        Next i

        If UBound(htable) = UBound(htTemp) Then Err.Raise 9998, , "Key [" & CStr(key) & "] not found"

        htable = htTemp
        RemoveValue = True
    Exit Function

RemoveErr:
    RemoveValue = False
    GetErrMsg = Err.Description
End Function

Private Function GetValue(htable() As hashtable, key As Variant) As Variant
    GetErrMsg = ""
    On Error GoTo GetValueErr
        Dim found As Boolean
        found = False

        For i = 1 To UBound(htable)
            If htable(i).key = key And IsEmpty(htable(i).key) = False Then
                GetValue = htable(i).value
                Exit Function
            End If
        Next i
        Err.Raise 9997, , "Key [" & CStr(key) & "] not found"

    Exit Function

GetValueErr:
    GetValue = ""
    GetErrMsg = Err.Description
End Function

Private Function GetValueCount(htable() As hashtable) As Long
    GetErrMsg = ""
    On Error GoTo GetValueCountErr
        GetValueCount = UBound(htable)
    Exit Function

GetValueCountErr:
    GetValueCount = 0
    GetErrMsg = Err.Description
End Function

Để sử dụng trong Ứng dụng VB (A) của bạn:

Public Sub Test()
    Dim hashtbl() As hashtable
    Debug.Print "Create Hashtable: " & CreateHashTable(hashtbl)
    Debug.Print ""
    Debug.Print "ID Test   Add V1: " & AddValue(hashtbl, "Hallo_0", "Testwert 0")
    Debug.Print "ID Test   Add V2: " & AddValue(hashtbl, "Hallo_0", "Testwert 0")
    Debug.Print "ID Test 1 Add V1: " & AddValue(hashtbl, "Hallo.1", "Testwert 1")
    Debug.Print "ID Test 2 Add V1: " & AddValue(hashtbl, "Hallo-2", "Testwert 2")
    Debug.Print "ID Test 3 Add V1: " & AddValue(hashtbl, "Hallo 3", "Testwert 3")
    Debug.Print ""
    Debug.Print "Test 1 Removed V1: " & RemoveValue(hashtbl, "Hallo_1")
    Debug.Print "Test 1 Removed V2: " & RemoveValue(hashtbl, "Hallo_1")
    Debug.Print "Test 2 Removed V1: " & RemoveValue(hashtbl, "Hallo-2")
    Debug.Print ""
    Debug.Print "Value Test 3: " & CStr(GetValue(hashtbl, "Hallo 3"))
    Debug.Print "Value Test 1: " & CStr(GetValue(hashtbl, "Hallo_1"))
    Debug.Print ""
    Debug.Print "Hashtable Content:"

    For i = 1 To UBound(hashtbl)
        Debug.Print CStr(i) & ": " & CStr(hashtbl(i).key) & " - " & CStr(hashtbl(i).value)
    Next i

    Debug.Print ""
    Debug.Print "Count: " & CStr(GetValueCount(hashtbl))
End Sub