Bài 11. Dictionary

[befaint]

Bài 11. Dictionary

(Danh sách các bài viết về VBA xem ở đây Index - Các bài viết về VBA)

Dictionary (Dic) là một phần trong thư viện Microsoft Scripting Runtime (scrrun.dll), cho phép lưu trữ và truy xuất số lượng lớn Item theo Key duy nhất tương ứng.

1. Khai báo
1.1. Kiểu khai báo sớm
(Có Tooltip khi gọi Dic, phải thiết lập trong Tools/References)
- Trong cửa sổ VBA, Tools menu, References.
- Tìm và check vào mục “Microsoft Scripting Runtime” trong cửa sổ References – VBAProject.
Khai báo trong code:

Dim Dic As Scripting.Dictionary
Set Dic = New Scripting.Dictionary

1.2. Kiểu khai báo muộn
(Không có Tooltip khi gọi Dic, không cần thiết lập trong Tools/References).
Khai báo trong code:

Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")

2. Các phương thức
2.1. Add

Dic.Add Key, Item

Thêm Item (đối tượng) vào Dic, yêu cầu Key của Item phải chưa tồn tại trong Dic.
Key: Nhận dữ liệu là kiểu số hoặc kiểu chuỗi, yêu cầu Key là duy nhất trong Dic.
Item: Nhận kiểu dữ liệu là chuỗi hoặc số, bao gồm cả rỗng. Item có thể là một giá trị đơn hoặc một mảng (Array).
Ví dụ:

Sub AddMethod()
    'Dic.Add Key, Item'
    Dim Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.Add "KeyA", 10
    Dic.Add "KeyB", "Item2"
    Dic.Add "KeyC", ""
    Dic.Add "KeyD", Array(20, 50)
End Sub

2.2. Exists

Dic.Exists(Key)

Kiểm tra sự tồn tại của một Key trong Dic. Trả về True nếu Key đó tồn tại trong Dic, ngược lại trả về False.
Ví dụ:

Sub ExistsMethod()
    'Dic.Exists(Key) '
    Dim Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.Add "KeyA", 10
    MsgBox Dic.Exists("KeyA")   'True'
End Sub

2.3. Remove

Dic.Remove(Key)

Xóa một Item trong Dic theo Key chỉ định. Nếu Key chỉ định chưa tồn tại trong Dic thì sẽ xảy ra lỗi.
Ví dụ:

Sub RemoveMethod()
    'Dic.Remove(Key) '
    Dim Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.Add "KeyA", 10
    Dic.Remove ("KeyA")
    MsgBox Dic.Exists("KeyA")   'False'
End Sub

2.4. RemoveAll

Dic.RemoveAll

Xóa tất cả các Items có trong Dic.
Ví dụ:

Sub RemoveAllMethod()
    'Dic.RemoveAll'
    Dim Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.Add "KeyA", 10
    Dic.Add "KeyB", 20
    Dic.RemoveAll
    MsgBox Dic.Count    '0'
End Sub

2.5. Items

Dic.Items

Trả về một mảng một chiều gồm toàn bộ Items có trong Dic.
Mảng một chiều này luôn có cận dưới bằng 0, dù khai báo Option Base 1
Ví dụ:

Sub ItemsMethod()
    'Dic.Items'
    Dim Dic As Object, Arr()
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.Add "KeyA", 10
    Dic.Add "KeyB", 20
    Arr = Dic.Items     'LBound(Arr) = 0'
End Sub

2.6. Keys

Dic.Keys

Trả về một mảng một chiều gồm toàn bộ Keys tồn tại trong Dic.
Mảng một chiều này luôn có cận dưới bằng 0, dù khai báo Option Base 1
Ví dụ:

Sub KeysMethod()
    'Dic.Keys'
    Dim Dic As Object, Arr()
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.Add "KeyA", 10
    Dic.Add "KeyB", 20
    Arr = Dic.Keys     'LBound(Arr) = 0'
End Sub

3. Thuộc tính
3.1. Item

Dic.Item(Key)
'Hoặc:'
Dic(Key)

- Gọi Item theo Key chỉ định. Nếu Key chỉ định chưa tồn tại trong Dic, thì Dic sẽ tự động thêm (Add) Key đó vào, và Item ứng với Key đó là rỗng.
- Thay đổi giá trị của Item theo Key chỉ định. Nếu Key chỉ định chưa tồn tại trong Dic, thì Dic sẽ tự động thêm (Add) key đó vào, và Item ứng với Key đó có giá trị vừa đưa vào.

Ví dụ:

Sub ItemProperty()
    'Dic.Item(Key)'
    'Dic(Key)   '
    Dim Dic As Object, x, y, z
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.Add "KeyA", 10
    Dic.Add "KeyB", 20
    x = Dic.Item("KeyA") '10'
    y = Dic("KeyA") '10'
    z = Dic("KeyC")
    Dic("KeyC") = 100
    MsgBox Dic.Item("KeyC") '100'
    MsgBox Dic.Count    '3'
End Sub

3.2. Key

Dic.Key(Key) = NewKey

Dùng để thay đổi giá trị mới của một Key chỉ định đã tồn tại trong Dic. Yêu cầu:
- Key chỉ định phải đã tồn tại trong Dic
- Giá trị mới của Key đó phải là duy nhất trong Dic (tức là có thể vẫn là giá trị cũ).
Ví dụ:

Sub KeyProperty()
    'Dic.Key(Key)=NewKey'
    Dim Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.Add "KeyA", 10
    Dic.Key("KeyA") = "KeyB"
End Sub

3.3. Count

Dic.Count

Trả về số Items có trong Dic.
Ví dụ:

Sub CountProperty()
    'Dic.Count '
    Dim Dic As Object, i As Long
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To 5
        Dic.Add "Key" & i, ""
    Next i
    MsgBox Dic.Count    '5'
End Sub

3.4. CompareMode

Dic.CompareMode = BinaryCompare
Dic.CompareMode = TextCompare

Thiết lập thuộc tính phân biệt chữ hoa chữ thường cho giá trị của Key.
BinaryCompare: (Giá trị mặc định của Dic) Phân biệt chữ hoa chữ thường
TextCompare: Không phân biệt chữ hoa chữ thường
Lưu ý: Thiết lập CompareMode cho Dic khi Dic rỗng (chưa có item nào trong Dic).
Ví dụ:

Sub CompareModeProperty()
    'Dic.CompareMode = vbBinaryCompare'
    'Dic.CompareMode = vbTextCompare '
    Dim Dic As Object, i As Long
    Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
      .CompareMode = vbBinaryCompare
      '.CompareMode = vbTextCompare '
      .Add "code", "lower"
      .Add "CODE", "UPPER"
    End With
End Sub

 

[batman1]

Không có gì buồn đâu anh, anh góp ý để tốt hơn mà. 1,2,3 em đã code lại. 4 thì chắc không cần chỉnh, chỉ là bảng dữ liệu mẫu thôi. 5 là do em chủ ý khai bao tên biến và viết như vậy để người mới dễ hiểu hơn thôi anh. Anh góp ý file mới tiếp nha.

Tôi không chạy thử nhưng nhìn code và dữ liệu thì thấy như sau.

Không phải xóa kết quả cũ như thế.
Hiện dữ liệu mới tới dòng 10. Giả sử kết quả cũ tới H15:J15. Code

Range("H2:J" & DongCuoi).Clear

là xóa H2:J10. Tức vẫn còn H11:J15.

Kết quả cho dữ liệu mới hiện hành chỉ có 3 dòng. Tức H2:J4. Nhưng do không xóa H11:J15 nên chúng vẫn còn.

 

[nguyenvanlinhab]

Không có gì buồn đâu anh, anh góp ý để tốt hơn mà. 1,2,3 em đã code lại. 4 thì chắc không cần chỉnh, chỉ là bảng dữ liệu mẫu thôi. 5 là do em chủ ý khai bao tên biến và viết như vậy để người mới dễ hiểu hơn thôi anh. Anh góp ý file mới tiếp nha.

code của anh phù hợp với người mới như em mong anh ra thêm nhiều chủ đề ạ

 

[Trần Văn Bình]

4. Ứng dụng
- Lọc loại trùng.
- Tạo dãy số ngẫu nhiên không trùng.
- …
4.1. Một số hàm
Hàm lọc loại trùng cột đầu tiên của một Range:

'//Loc loai trung mot cot'
Function UniqueColumn1D(ByVal Rng As Range) As Variant
    If Rng.Count = 1 Then UniqueColumn1D = Rng.Value: Exit Function
    Dim Dic As Object, i As Long, arr()
    arr = Rng.Value
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = LBound(arr, 1) To UBound(arr, 1)
        If arr(i, 1) <> "" And Dic.Exists(arr(i, 1)) = False Then
            Dic.Add arr(i, 1), ""
        End If
    Next i
    UniqueColumn1D = Dic.Keys
End Function

Hàm lọc loại trùng cột đầu tiên cho mảng 2 chiều:

'//Loc loai trung mang 2 chieu'
Function UniqueArray(ByVal arr As Variant) As Variant
    If IsArray(arr) = False Then Exit Function
    Dim Dic As Object, i As Long
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = LBound(arr, 1) To UBound(arr, 1)
        If arr(i, 1) <> "" And Dic.Exists(arr(i, 1)) = False Then
            Dic.Add arr(i, 1), ""
        End If
    Next i
    UniqueArray = Dic.Keys
End Function

4.2. Ví dụ
Cho bảng dữ liệu như dưới. Yêu cầu, căn cứ vào cột B – Code để loại loại trùng, kết quả trả về gồm 4 cột dữ liệu:
|No.| là thứ tự danh mục Code,
|Code| là danh mục Code sau khi loại trùng,
|Date| là ngày ứng với Code đầu tiên tìm thấy, xét từ trên xuống,
|Quantity| là tổng ứng với mỗi Code lọc được.

View attachment 184038

- Code trong Module:

Sub FilterData()
'Sub loc loai trung theo cot [Code] - côt [B]'
Dim Dic As Object
Dim Rng As Range, i As Long, lRow As Long, ArrData(), Result(), iTmp As String, j As Long
Set Dic = CreateObject("Scripting.Dictionary")
'Gan doi tuong Dictionary vao bien Dic'
With Sheet1
'Xét sheet1'
    lRow = .Range("B" & Rows.Count).End(xlUp).Row
    'Tra ve dong cuoi cung co du lieu thuoc cot [B]'
    ArrData = .Range("B2:D" & lRow).Value2
    'Gan vung du lieu [B2:D & lRow] vao bien mang ArrData'
    lRow = UBound(ArrData, 1)
    'Tra ve kich thuoc chieu thu nhat cua mang ArrData'
    ReDim Result(1 To lRow, 1 To 4)
    'Khai bao cu the so chieu va kich thuoc chieu cho bien mang Result'
    For i = 1 To lRow
    'Xet vong lap bien i chay tu 1 toi lRow
        iTmp = ArrData(i, 1)
        'Gan phan tu (i,1) cua mang ArrData vao bien iTmp
        If iTmp <> "" Then
        'Xet iTmp, neu khac rong thi
            If Not Dic.Exists(iTmp) Then
            'Xet iTmp, neu chua ton tai trong Dic thi
                j = j + 1
                'Tang gia tri cua j len 1 don vi
                Dic.Add iTmp, j
                'Them item co gia tri = j ung voi key = iTmp
                'Truyen ket qua vao bien mang Result:
                Result(j, 1) = j
                Result(j, 2) = iTmp
                Result(j, 3) = ArrData(i, 2)
                Result(j, 4) = ArrData(i, 3)
            Else
            'Nguoc lai: iTmp da ton tai trong Dic thi
                Result(Dic.Item(iTmp), 4) = Result(Dic.Item(iTmp), 4) + ArrData(i, 3)
                'Cong don so luong vao phan tu cua mang Result co chi so (Dic.Item(iTmp), 4)
            End If
        End If
    Next i
    If j > 0 Then
    'Xet j >: Tuc la co ket qua loc
        .Range("H2").Resize(100, 4).ClearContents
        'Xoa du lieu trong vung gan ket qua
        .Range("H2").Resize(j, 4) = Result
        'Gan ket qua xuong bang tinh
    End If
End With
End Sub

Sub FilterData() em nuốn lấy thêm điều kiện

Result trong khoảng từ ngày đến ngày thì khai báo biến thế nào bạn