Hash-Tabelle / Assoziatives Array in VBA

Ich kann nicht scheinen zu finden, die Dokumentation welche erklären, wie man erstellen Sie eine hash-Tabelle oder ein assoziatives array in VBA. Ist es überhaupt möglich?

Können Sie einen link auf einen Artikel oder noch besser: poste den code?

InformationsquelleAutor der Frage Tyler | 2009-08-21

100

Ich denke, Sie sind auf der Suche für das Dictionary-Objekt finden Sie in der Microsoft Scripting Runtime-Bibliothek. (Fügen Sie einen Verweis auf das Projekt von den Extras...Verweise in der VBE.)

Er ziemlich viel arbeitet mit einem einfachen Wert, die passen in eine Variante (Schlüssel kann nicht sein, arrays, und zu versuchen, Sie zu Objekten macht nicht viel Sinn. Siehe Kommentar von @NiL unten.):
```
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
```
Können Sie auch verwenden, die VBA Collection-Objekt, wenn Ihre Bedürfnisse sind einfacher und Sie wollen einfach nur string-Schlüssel.

Ich weiß nicht, ob tatsächlich hashes auf alles, so möchten Sie vielleicht, weiter zu Graben, wenn Sie brauchen, hashtable-artigen performance. (EDIT: Scripting.Wörterbuch nicht eine Hashtabelle intern.)

InformationsquelleAutor der Antwort jtolle
8

Ich verwendet habe, Francesco Balena die HashTable-Klasse mehrere Male in der Vergangenheit, wenn Sie eine Collection oder ein Dictionary war nicht eine perfekte Passform, und ich brauchte nur eine HashTable.

InformationsquelleAutor der Antwort Mark Nold
7

Versuchen Sie mit dem Dictionary-Objekt oder Collection-Objekt.

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

InformationsquelleAutor der Antwort Disco

Here we go... kopieren Sie einfach den code zu einem Modul, es ist bereit zu verwenden

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

Zur Verwendung in VB(A) - App:

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

InformationsquelleAutor der Antwort Stefan0410

Schreibe einen Kommentar

Du musst angemeldet sein, um einen Kommentar abzugeben.