VBAでハッシュテーブルまたは連想配列を作成する方法を説明するドキュメントが見つからないようです。それも可能ですか?
記事にリンクできますか、コードを投稿できますか?
Microsoft Scripting Runtimeライブラリにある辞書オブジェクトを探していると思います。 (VBEの[ツール...参照]メニューからプロジェクトへの参照を追加します。)
バリアントに収まる単純な値であればほとんど機能します(キーを配列にすることはできず、オブジェクトを作成しようとしても意味がありません。以下の@Nileのコメントを参照してください)。
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
ニーズがより単純で、文字列キーだけが必要な場合は、VBA Collectionオブジェクトを使用することもできます。
いずれかが実際にハッシュされているかどうかはわかりませんので、ハッシュテーブルのようなパフォーマンスが必要な場合は、さらに掘り下げてください。 (編集:Scripting.Dictionaryは ハッシュテーブル を内部的に使用します。)
私は Francesco BalenaのHashTableクラス を使用しましたが、過去にコレクションまたは辞書が完全に適合せず、HashTableが必要だったときに何度か使用しました。
辞書オブジェクトまたはコレクションオブジェクトを使用してみてください。
http://visualbasic.ittoolbox.com/documents/dictionary-object-vs-collection-object-12196
コードをモジュールにコピーするだけで、すぐに使用できます
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
VB(A)アプリで使用するには:
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