Click here to Skip to main content
Click here to Skip to main content

Tagged as

Go to top

A quick & simple VBA HashTable Implementation

, 8 Jul 2010
Rate this:
Please Sign up or sign in to vote.
VBA Hashtable Visual Basic Hash
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
 

 

 

' ************ TEST

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
&able

License

This article, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)

Share

About the Author

Stefan Huy
Engineer
Germany Germany
No Biography provided
Follow on   Twitter   LinkedIn

Comments and Discussions

 
GeneralReason for my vote of 5 Simple but effective PinmemberT_uRRiCA_N22-Jul-10 6:52 

General General    News News    Suggestion Suggestion    Question Question    Bug Bug    Answer Answer    Joke Joke    Rant Rant    Admin Admin   

Use Ctrl+Left/Right to switch messages, Ctrl+Up/Down to switch threads, Ctrl+Shift+Left/Right to switch pages.

| Advertise | Privacy | Mobile
Web01 | 2.8.140916.1 | Last Updated 8 Jul 2010
Article Copyright 2010 by Stefan Huy
Everything else Copyright © CodeProject, 1999-2014
Terms of Service
Layout: fixed | fluid