Apakah VBA memiliki Struktur Kamus?

Apakah VBA memiliki struktur kamus? Suka array nilai kunci <>?

Iya.

Tetapkan referensi untuk runtime MS Scripting ('Microsoft Scripting Runtime'). Sesuai komentar @ regjo, pergi ke Tools-> Referensi dan centang kotak untuk 'Microsoft Scripting Runtime'.

Buat instance kamus menggunakan kode di bawah ini:

Set dict = CreateObject("Scripting.Dictionary")

atau

Dim dict As New Scripting.Dictionary 

Contoh penggunaan:

If Not dict.Exists(key) Then 
    dict.Add key, value
End If 

Jangan lupa mengatur kamus Nothingsaat Anda selesai menggunakannya.

Set dict = Nothing 

VBA memiliki objek koleksi:

    Dim c As Collection
    Set c = New Collection
    c.Add "Data1", "Key1"
    c.Add "Data2", "Key2"
    c.Add "Data3", "Key3"
    'Insert data via key into cell A1
    Range("A1").Value = c.Item("Key2")

The Collectionobjek Melakukan pencarian berbasis kunci menggunakan hash sehingga sangat cepat.

Anda dapat menggunakan Contains()fungsi untuk memeriksa apakah koleksi tertentu berisi kunci:

Public Function Contains(col As Collection, key As Variant) As Boolean
    On Error Resume Next
    col(key) ' Just try it. If it fails, Err.Number will be nonzero.
    Contains = (Err.Number = 0)
    Err.Clear
End Function

Sunting 24 Juni 2015 : Contains()Terima kasih lebih pendek untuk @TWiStErRob.

Sunting 25 September 2015 : Ditambahkan Err.Clear()berkat @scipilot.

VBA tidak memiliki implementasi internal kamus, tetapi dari VBA Anda masih dapat menggunakan objek kamus dari MS Scripting Runtime Library.

Dim d
Set d = CreateObject("Scripting.Dictionary")
d.Add "a", "aaa"
d.Add "b", "bbb"
d.Add "c", "ccc"

If d.Exists("c") Then
    MsgBox d("c")
End If

Contoh kamus tambahan yang berguna untuk memuat frekuensi kemunculan.

Di luar lingkaran:

Dim dict As New Scripting.dictionary
Dim MyVar as String

Dalam satu lingkaran:

'dictionary
If dict.Exists(MyVar) Then
    dict.Item(MyVar) = dict.Item(MyVar) + 1 'increment
Else
    dict.Item(MyVar) = 1 'set as 1st occurence
End If

Untuk memeriksa frekuensi:

Dim i As Integer
For i = 0 To dict.Count - 1 ' lower index 0 (instead of 1)
    Debug.Print dict.Items(i) & " " & dict.Keys(i)
Next i

Membangun jawaban cjrh , kita dapat membangun fungsi Contains yang tidak memerlukan label (saya tidak suka menggunakan label).

Public Function Contains(Col As Collection, Key As String) As Boolean
    Contains = True
    On Error Resume Next
        err.Clear
        Col (Key)
        If err.Number <> 0 Then
            Contains = False
            err.Clear
        End If
    On Error GoTo 0
End Function

Untuk proyek saya, saya menulis satu set fungsi pembantu untuk membuat Collectionperilaku lebih seperti a Dictionary. Itu masih memungkinkan koleksi rekursif. Anda akan melihat Key selalu didahulukan karena itu wajib dan lebih masuk akal dalam implementasi saya. Saya juga hanya menggunakan Stringkunci. Anda dapat mengubahnya kembali jika Anda mau.

Set

Saya mengganti nama ini untuk ditetapkan karena akan menimpa nilai lama.

Private Sub cSet(ByRef Col As Collection, Key As String, Item As Variant)
    If (cHas(Col, Key)) Then Col.Remove Key
    Col.Add Array(Key, Item), Key
End Sub

Dapatkan

The errhal ini untuk benda karena Anda akan melewati objek menggunakan setdan variabel tanpa. Saya pikir Anda hanya dapat memeriksa apakah itu objek, tapi saya terdesak waktu.

Private Function cGet(ByRef Col As Collection, Key As String) As Variant
    If Not cHas(Col, Key) Then Exit Function
    On Error Resume Next
        err.Clear
        Set cGet = Col(Key)(1)
        If err.Number = 13 Then
            err.Clear
            cGet = Col(Key)(1)
        End If
    On Error GoTo 0
    If err.Number <> 0 Then Call err.raise(err.Number, err.Source, err.Description, err.HelpFile, err.HelpContext)
End Function

Memiliki

Alasan posting ini ...

Public Function cHas(Col As Collection, Key As String) As Boolean
    cHas = True
    On Error Resume Next
        err.Clear
        Col (Key)
        If err.Number <> 0 Then
            cHas = False
            err.Clear
        End If
    On Error GoTo 0
End Function

Menghapus

Tidak melempar jika tidak ada. Pastikan itu dihapus.

Private Sub cRemove(ByRef Col As Collection, Key As String)
    If cHas(Col, Key) Then Col.Remove Key
End Sub

Kunci

Dapatkan berbagai kunci.

Private Function cKeys(ByRef Col As Collection) As String()
    Dim Initialized As Boolean
    Dim Keys() As String

    For Each Item In Col
        If Not Initialized Then
            ReDim Preserve Keys(0)
            Keys(UBound(Keys)) = Item(0)
            Initialized = True
        Else
            ReDim Preserve Keys(UBound(Keys) + 1)
            Keys(UBound(Keys)) = Item(0)
        End If
    Next Item

    cKeys = Keys
End Function

Kamus runtime scripting tampaknya memiliki bug yang dapat merusak desain Anda pada tahap lanjut.

Jika nilai kamus adalah sebuah array, Anda tidak dapat memperbarui nilai elemen yang terkandung dalam array melalui referensi ke kamus.

Iya. Untuk VB6 , VBA (Excel), dan VB.NET

Jika karena alasan apa pun, Anda tidak dapat menginstal fitur tambahan ke Excel Anda atau tidak mau, Anda dapat menggunakan array juga, setidaknya untuk masalah sederhana. Sebagai WhatIsCapital, Anda memasukkan nama negara dan fungsinya mengembalikan modal Anda.

Sub arrays()
Dim WhatIsCapital As String, Country As Array, Capital As Array, Answer As String

WhatIsCapital = "Sweden"

Country = Array("UK", "Sweden", "Germany", "France")
Capital = Array("London", "Stockholm", "Berlin", "Paris")

For i = 0 To 10
    If WhatIsCapital = Country(i) Then Answer = Capital(i)
Next i

Debug.Print Answer

End Sub

Semua yang lain telah menyebutkan penggunaan versi scripting.runtime dari kelas Kamus. Jika Anda tidak dapat menggunakan DLL ini, Anda juga dapat menggunakan versi ini, cukup tambahkan ke kode Anda.

https://github.com/VBA-tools/VBA-Dictionary/blob/master/Dictionary.cls

Ini identik dengan versi Microsoft.