[TẶNG] Thuật toán lọc tìm kiếm mới trên ComboBox.

[Hoàng Trọng Nghĩa]

Mặc dù cách lọc mới này cũng là những vòng lặp để duyệt từng hàng trên mảng như những thuật toán lọc hiện hành, nhưng tôi "phát minh" ra một kiểu lọc mới có thể giảm được thời gian từ bằng việc lọc thông thường cho đến nhanh hơn rất nhiều.

Cụ thể là lọc thông thường các coder thường lấy mảng gốc để lọc cho bất cứ từ khóa (key) nào, còn tôi sẽ lọc được mảng nào lưu tạm lại mảng đó để dùng lọc cho các từ khóa sau. Vì vậy khi bạn gõ ký tự đầu tiên sẽ có thời gian lọc như các kiểu lọc thông thường, nhưng từ ký tự thứ 2 và thứ n sẽ giảm dần theo dữ liệu còn lại trên mảng lưu tạm.

Và cứ mỗi ký tự bị xóa nó sẽ trả lại mảng tương ứng đã lọc trước đó cho nên nó không mất thời gian cho việc lọc lại.

Code này tôi viết để lọc cho ComboBox, nhưng nếu ai muốn tùy biến trên TextBox và gán dữ liệu vào ListBox cũng không vấn đề gì.

Và code này tôi xin tặng các bạn nhân mùa dịch khủng khiếp này. Tôi cũng rất mong được các bạn góp ý cho những trường hợp làm cho nó hoàn thiện hơn, nhanh hơn.

Tôi tạm lấy hơn 11 ngàn phường xã trong nước x 10 lần để có số hàng 111,620 dòng để test.

Private Sub cbxPhuongXa_Change()
    If cbxPhuongXa.Text = "" Then
        ReDim Preserve priArrPhuongXa(0 To 0)
        cbxPhuongXa.Column = priArrPhuongXa(0)
        GoTo ExitSub
    End If
 
    On Error GoTo ExitSub
    Dim c As Long, lngLenText As Long, lngUbd As Long
 
    lngLenText = Len(cbxPhuongXa.Text)
    lngUbd = UBound(priArrPhuongXa)
     
    c = lngLenText - 1
 
    If Not IsArray(priArrPhuongXa(c)) Then
        cbxPhuongXa.Clear
        ReDim Preserve priArrPhuongXa(0 To lngLenText)
        GoTo ExitSub
    End If
 
    If lngUbd > lngLenText Then
        If Not IsArray(priArrPhuongXa(lngLenText)) Then
            cbxPhuongXa.Clear
            cbxPhuongXa.ForeColor = &H800000
        Else
            cbxPhuongXa.Column = priArrPhuongXa(lngLenText)
        End If
        ReDim Preserve priArrPhuongXa(0 To lngLenText)
        GoTo ExitSub
    End If
     
    If Right(cbxPhuongXa.Text, 1) = "*" Or Right(cbxPhuongXa.Text, 1) = "?" Then
        ReDim Preserve priArrPhuongXa(0 To lngLenText)
        priArrPhuongXa(lngLenText) = priArrPhuongXa(lngUbd)
        GoTo ExitSub
    End If
     
    Dim arrFilter()
    Dim strType As String, strTemp As String, strColOne As String
    Dim n As Long, r As Long, t As Long, uCol As Long, uRow As Long
     
    c = lngLenText - 1
    lRow = LBound(priArrPhuongXa(c), 2): uRow = UBound(priArrPhuongXa(c), 2)
 
    strTemp = UCase(LoaiDauUni(cbxPhuongXa.Text))
    strType = "*" & strTemp & "*"
    strTypeTwo = strTemp & "*"
     
    For r = lRow To uRow
        strColOne = UCase(LoaiDauUni(priArrPhuongXa(c)(0, r)))
        If strColOne Like strType Then
            ReDim Preserve arrFilter(0 To 0, 0 To n)
            arrFilter(0, n) = priArrPhuongXa(c)(0, r)
            n = n + 1
        End If
    Next
 
    If n Then
        ReDim Preserve priArrPhuongXa(0 To lngLenText)
        priArrPhuongXa(lngLenText) = arrFilter
        cbxPhuongXa.Column = arrFilter
    Else
        cbxPhuongXa.Clear
        cbxPhuongXa.ForeColor = &H800000
        ReDim Preserve priArrPhuongXa(0 To lngLenText)
    End If

ExitSub:
    If cbxPhuongXa.ListCount > 0 Then cbxPhuongXa.DropDown
End Sub

Tôi cũng khuyến mại thêm cho các bạn Hàm LoaiDauUni để loại bỏ dấu tiếng Việt kiểu gõ Unicode (dựng sẵn).

Function LoaiDauUni(ByVal strText As String) As String
    If strText = "" Then Exit Function
    Static ObjDict As Object
    Static blnInitial As Boolean
 
    If Not blnInitial Then
        Dim c As Byte
        Dim arrNoMarks, arrUnicode
        arrUnicode = Array(192, 193, 194, 195, 200, 201, 202, 204, 205, 210, 211, 212, _
                            213, 217, 218, 221, 224, 225, 226, 227, 232, 233, 234, 236, 237, _
                            242, 243, 244, 245, 249, 250, 253, 258, 259, 272, 273, 296, 297, _
                            360, 361, 416, 417, 431, 432, 7840, 7841, 7842, 7843, 7844, 7845, _
                            7846, 7847, 7848, 7849, 7850, 7851, 7852, 7853, 7854, 7855, 7856, _
                            7857, 7858, 7859, 7860, 7861, 7862, 7863, 7864, 7865, 7866, 7867, _
                            7868, 7869, 7870, 7871, 7872, 7873, 7874, 7875, 7876, 7877, 7878, _
                            7879, 7880, 7881, 7882, 7883, 7884, 7885, 7886, 7887, 7888, 7889, _
                            7890, 7891, 7892, 7893, 7894, 7895, 7896, 7897, 7898, 7899, 7900, _
                            7901, 7902, 7903, 7904, 7905, 7906, 7907, 7908, 7909, 7910, 7911, _
                            7912, 7913, 7914, 7915, 7916, 7917, 7918, 7919, 7920, 7921, 7922, _
                            7923, 7924, 7925, 7926, 7927, 7928, 7929)
        arrNoMarks = Array("A", "A", "A", "A", "E", "E", "E", "I", "I", "O", "O", "O", "O", _
                            "U", "U", "Y", "a", "a", "a", "a", "e", "e", "e", "i", "i", "o", "o", _
                            "o", "o", "u", "u", "y", "A", "a", "D", "d", "I", "i", "U", "u", "O", _
                            "o", "U", "u", "A", "a", "A", "a", "A", "a", "A", "a", "A", "a", "A", _
                            "a", "A", "a", "A", "a", "A", "a", "A", "a", "A", "a", "A", "a", "E", _
                            "e", "E", "e", "E", "e", "E", "e", "E", "e", "E", "e", "E", "e", "E", _
                            "e", "I", "i", "I", "i", "O", "o", "O", "o", "O", "o", "O", "o", "O", _
                            "o", "O", "o", "O", "o", "O", "o", "O", "o", "O", "o", "O", "o", "O", _
                            "o", "U", "u", "U", "u", "U", "u", "U", "u", "U", "u", "U", "u", "U", _
                            "u", "Y", "y", "Y", "y", "Y", "y", "Y", "y")
        Set ObjDict = CreateObject("Scripting.Dictionary")
        For c = 0 To 133
            ObjDict(arrUnicode(c)) = arrNoMarks(c)
        Next
        blnInitial = True
    End If
 
    Dim i As Long, j As Long, lngAscW As Long
    For i = 1 To Len(strText)
        lngAscW = AscW(Mid(strText, i, 1))
        If lngAscW > 191 Then
            Mid(strText, i, 1) = ObjDict.Item(lngAscW)
        End If
    Next
    LoaiDauUni = strText
End Function

P/S: Nếu muốn lọc mà không cần hàm LoaiDauUni để nhanh hơn, hãy xem bài #58.

 

[tigertiger]

Gửi chủ topic:

Có những mẹo mực trong sử dụng viết code của bạn khá hay , giúp cho mọi người có thểá p dụng vào thể loại bài khác tương tự

Tuy nhiên:

+ Ở đây có vẻ lạm dụng từ: phát minh, thuật toán tìm kiếm mới, chưa ai làm-- (cũng có thể tôi nhầm chăng vơi các nghĩa của từ này của Việt nam ta?)

+ Khẳng định rằng đây không có gì mới, vì nhanh trong hạn chế ứng dụng (đánh đúng thứ tự, không được lùi xóa, tìm kiếm không chính xác cả từ, cụm từ). - thì đó không phải là nhanh thật

+ So sánh nhanh thì phải cùng trường hợp, còn hạn chế so với tổng quát (tìm cả cụm từ có dấu và không hạn chế phải gõ theo đúng thứ tự) ---> thì khó rồi

 

[ongke0711]

Bug không phải lúc nào cũng xấu nhỉ...

 

[queluatb]

    For r = lRow To uRow
        strColOne = UCase(LoaiDauUni(priArrPhuongXa(c)(0, r)))
        If strColOne Like strType Then
            ReDim Preserve arrFilter(0 To 0, 0 To n)
            arrFilter(0, n) = priArrPhuongXa(c)(0, r)
            n = n + 1
        End If
    Next

strColOne = UCase(LoaiDauUni(priArrPhuongXa(c)(0, r)))
Mỗi lần nhập thêm ký tự lệnh trên sẽ chạy lại dữ liệu đã xử lý

em đang tìm hiểu về userform anh có thể chỉ giúp em mục đích của Redim Preserve ở đây có ý nghĩa như nào không, theo em hiểu Redim Preserve chỉ tăng kích thước ở chiều thứ 2 và muốn chuyển sang dòng phải qua Transpose

 

[HieuCD]

em đang tìm hiểu về userform anh có thể chỉ giúp em mục đích của Redim Preserve ở đây có ý nghĩa như nào không, theo em hiểu Redim Preserve chỉ tăng kích thước ở chiều thứ 2 và muốn chuyển sang dòng phải qua Transpose

Code của @Hoàng Trọng Nghĩa , bạn hỏi bạn Nghĩa nha

 

[Hoàng Trọng Nghĩa]

em đang tìm hiểu về userform anh có thể chỉ giúp em mục đích của Redim Preserve ở đây có ý nghĩa như nào không, theo em hiểu Redim Preserve chỉ tăng kích thước ở chiều thứ 2 và muốn chuyển sang dòng phải qua Transpose

Redim Preserve dùng để khai báo thêm bớt chiều thứ 2 (chiều cuối cùng). Do chúng ta lấy mảng từ ComboBox từ Column chứ không phải từ List nên hàng trở thành cột và cột trở thành hàng, nói nôm na là vậy, vì thế nó có thể thay đổi chiều thứ 2 mà không cần phải Transpose, thuật toán này sẽ nhanh hơn kiểu thông thường.

 

[quangman]

Cái vụ Clear hay thay bằng mảng rỗng chỉ xảy ra khi và chỉ khi không lọc được gì, điều này không ảnh hưởng gì đến thời gian lọc 3 ký tự hay nhiều hơn thế trên code của em. Nhưng qua đây em cũng trải nghiệm ra được nhiều điều thú vị để tiếp tục khám phá ra những điều mới mẻ hơn nữa.
Cám ơn vì tất cả.

Mình hơi kém cái này nên cho mình hỏi thêm chút nha, mình muốn tìm kiếm trên nhiều cột khác của bản dữ liệu thì mình làm sao?

 

[quangman]

Code này không dùng được trong trường hợp tổng quát. Vì muốn dùng thì phải nhập dữ liệu theo đúng trình tự mà bạn bắt buộc. Vd. tôi nhập "sương" và có loạt kết quả chứa "sương". Lúc này tôi mới nhận ra lỗi chính tả, phải là "xương". Tôi muốn click trước hoặc sau "s" rồi dùng Delete hoặc Backspace để xóa "s" thì không được. Trỏ văn bản cứ nhẩy về cuối khi tôi click ở giữa từ, nên tôi phải nhấn phím mũi tên trái 4 lần. Sau khi xóa "s" tôi nhấn "x" để có "xương" thì không có kết quả nào dù dữ liệu có "xương". Hoặc lẽ ra phải gõ "Phong" thì do nhấn phím hơi lâu nên thành "Phoong". Bây giờ có xóa 1 "o" thì cũng không có kết quả dù dữ liệu có "Phong". Nhớ danh sách cuối để lọc từ đó thì nhiều người cũng nghĩ tới rồi chứ không phải là điều mới, nhưng nó đòi hỏi nhập và chỉnh sửa theo một cách nhất định. Ngoài ra nếu tôi gõ "phu" là tôi muốn tìm "phu" chứ không phải cả "phù", "phủ", "phũ", "phú", "phụ".

Tôi viết nhanh một code mà bạn gọi là thuật toán lọc hiện hành, lấy mảng gốc để lọc. Bạn thử kiểm tra tốc độ xem. Cứ gõ ký tự 1, rồi 2, ...

Đố bạn biết chỗ nhanh ở đâu, cái gì nó làm code nhanh hẳn.

code này hay quá anh ơi, cho em hỏi muốn tìm kiếm thêm ở các cột khác trong bảng dữ liệu thì làm sao?

 

[Cao Mạnh Sơn]

Góp vui chút về cái lọc này.

Dim rst As Object
Private Sub cbxPhuongXa_Change()
    Dim arr As Variant
    With cbxPhuongXa
        If .Text = "" Then
            rst.Filter = 0
        Else
            rst.Filter = "[" & Sheet2.Range("A1") & "] Like '*" & .Text & "*'"
        End If
        If rst.EOF Then
            .Clear
        Else
            arr = rst.getrows()
            .Column = arr
            .DropDown
        End If
    End With
End Sub

Private Sub UserForm_Initialize()
    Set rst = CreateObject("ADODB.Recordset")
    Dim objXML As Object
    Set objXML = CreateObject("MSXML2.DOMDocument")
    objXML.LoadXML Sheet2.Range("A1:A111621").Value(12)
    rst.Open objXML
End Sub

Tôi test như sau: chèn 1 dòng trống vào vùng dữ liệu, cụ thể là dòng 2, chạy code bị lỗi. Chèn dòng trống bất kỳ từ dòng 3 trở đi: Code chạy OK. Chèn dòng trống vào dòng 1: code lỗi. chèn dòng trống vào dòng 1 và sửa code cho tương thích với vùng dữ liệu từ A2 thay vì A1: vẫn bị lỗi. Xin hỏi mọi người nguyên nhân lỗi và tùy biến code trên như thế nào để lọc từ 1 vùng bất kỳ trên trang tính. Cám ơn.

 

[Hoàng Trọng Nghĩa]

code này hay quá anh ơi, cho em hỏi muốn tìm kiếm thêm ở các cột khác trong bảng dữ liệu thì làm sao?

Dữ liệu thế nào? Nói rõ hơn không?

 

[quangman]

Dữ liệu thế nào? Nói rõ hơn không?

mỗi hàng dữ liệu gồm 5 cột: mã hàng hóa, tên hàng hóa, kích thước, màu sắc, chất liệu

 

[Hoàng Trọng Nghĩa]

mỗi hàng dữ liệu gồm 5 cột: mã hàng hóa, tên hàng hóa, kích thước, màu sắc, chất liệu

Bạn gửi file lên xem nào?

 

[Cao Mạnh Sơn]

Tôi có câu hỏi ở #68 không thấy ai trả lời giúp. Hai Lúa Miền Tây có thể trả lời giúp được không ??? xin cám ơn