Hash-Tabelle/Assoziatives Array in VBA

Question

Ich kann nicht scheinen, die Dokumentation zu finden, die erklärt, wie man eine Hash-Tabelle oder ein assoziatives Array in VBA erstellt. Ist es überhaupt möglich?

Können Sie auf einen Artikel verlinken oder besser noch den Code posten?

Answer 1

Ich glaube, Sie für das Dictionary-Objekt suchen, in der Microsoft Scripting Runtime-Bibliothek gefunden. (Fügen Sie einen Verweis auf Ihr Projekt aus dem Menü Extras ... Verweise in der VBE hinzu.)

Es funktioniert ziemlich gut mit jedem einfachen Wert, der in eine Variante passen kann (Keys können keine Arrays sein und versuchen zu machen sie Objekte nicht viel Sinn machen sehen von @Nile Kommentar 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 

Sie können auch das VBA Collection-Objekt verwenden, wenn Ihre Bedürfnisse einfacher sind und Sie wollen einfach nur String-Schlüssel.

Ich weiß nicht, ob beide tatsächlich auf etwas Hashes, also möchten Sie vielleicht weiter graben, wenn Sie Hashtable-ähnliche Leistung benötigen. (EDIT: Scripting.Dictionary verwendet intern eine hash table.)

Answer 2

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

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

Answer 3

Ich habe Francesco Balena's HashTable class mehrmals in der Vergangenheit verwendet, wenn eine Sammlung oder ein Wörterbuch nicht eine perfekte Passform war und ich brauchte nur eine HashTable.

Answer 4

Hier gehen wir ... kopieren Sie einfach den Code zu einem Modul, es ist bereit

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 

verwenden in Ihrem VB verwenden (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