Tối ưu chức năng tìm kiếm bằng Combobox khi dữ liệu lớn

Liên hệ QC

sacalataba127

Thành viên hoạt động
Tham gia
6/4/16
Bài viết
148
Được thích
12
Giới tính
Nam
Dạ chào các bác các anh, chị và các bạn.
Mình có vấn đề này cần mọi người góp ý giùm với ạ
Tình hình là mình tạo combobox có chức năng tìm kiếm mã khách hàng ở cột KHÁCH HÀNG
với lượng dữ liệu ít thì chạy code rất nhanh, nhưng khi dữ liệu nhiều thì chạy chậm và bị lag
Không biết là code của mình có thể tối ưu, hơn chút và làm nó chạy nhanh hơn được không
Mình có gửi file đính kèm, mọi người xem giùm ạ.
 

File đính kèm

  • BAOCAOTONG.xlsm
    192.3 KB · Đọc: 55
Mọi người xem giùm với ạ. ;););):D
 
MỌi người ơi có giải pháp gì giúp mình với ạ.
 
:D:D:D
mọi người ơi, nên làm thế nào đây ạ
 
Dạ chào các bác các anh, chị và các bạn.
Mình có vấn đề này cần mọi người góp ý giùm với ạ
Tình hình là mình tạo combobox có chức năng tìm kiếm mã khách hàng ở cột KHÁCH HÀNG
với lượng dữ liệu ít thì chạy code rất nhanh, nhưng khi dữ liệu nhiều thì chạy chậm và bị lag
Không biết là code của mình có thể tối ưu, hơn chút và làm nó chạy nhanh hơn được không
Mình có gửi file đính kèm, mọi người xem giùm ạ.
Bạn có thể tìm kiếm bằng form.
 
Dạ chào các bác các anh, chị và các bạn.
Mình có vấn đề này cần mọi người góp ý giùm với ạ
Tình hình là mình tạo combobox có chức năng tìm kiếm mã khách hàng ở cột KHÁCH HÀNG
với lượng dữ liệu ít thì chạy code rất nhanh, nhưng khi dữ liệu nhiều thì chạy chậm và bị lag
Không biết là code của mình có thể tối ưu, hơn chút và làm nó chạy nhanh hơn được không
Mình có gửi file đính kèm, mọi người xem giùm ạ.
Thử code
Mã:
Option Explicit
Dim Dic As Object
Private Sub Worksheet_Activate()
  Dim i As Long, k As Long, sArr(), ikey
  Set Dic = CreateObject("scripting.dictionary")
  With Sheet2
    k = .Range("C1000000").End(xlUp).Row
    If k < 26 Then
      Dic.Add Empty, Empty
    Else
      sArr = .Range("C26:C" & k).Value
      k = UBound(sArr)
      For i = 1 To k
        ikey = UCase(sArr(i, 1))
        If Len(ikey) > 0 Then Dic.Item(ikey) = Empty
      Next i
    End If
  End With

  With Range("L5")
    Me.ComboBox2.Height = .Height + 5
    Me.ComboBox2.Width = .Width + 5
    Me.ComboBox2.Top = .Top
    Me.ComboBox2.Left = .Left
    Me.ComboBox2.Font.Size = 22
  End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal vitri As Range)
  Dim KH
  If vitri.Address = "$L$5" Then
    KH = Range("L5").Value
    If KH <> "" Then If Not Dic.exists(KH) Then Range("L5") = ""
    Me.ComboBox2.List = Dic.keys
    Me.ComboBox2.Visible = True
    Me.ComboBox2.Activate
    Me.ComboBox2.Text = KH
  Else
    KH = Me.ComboBox2.Text
    Me.ComboBox2.Visible = False
  End If
End Sub

'COMBOBOX
Private Sub ComboBox2_Change() 'NHAP TEN KHACH HANG TRUC TIEP
    On Error Resume Next
    Dim KH As String, k As Long, tmp
    KH = UCase(Me.ComboBox2.Text)
    If KH = "" Then
      Me.ComboBox2.TopIndex = 0
    ElseIf Not Dic.exists(KH) Then
        KH = "*" & KH & "*"
        k = 0
        For Each tmp In Dic.keys
          If UCase(tmp) Like KH Then
            Me.ComboBox2.TopIndex = k: Exit For
          End If
          k = k + 1
        Next tmp
        Me.ComboBox2.DropDown
    Else
      Range("L5").Value = Me.ComboBox2
    End If
End Sub
Private Sub ComboBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)                         'DOUBLE CLICK CHON
    Me.ComboBox2.DropDown
End Sub
Private Sub ComboBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 'PHIM ENTER CHON
    If KeyCode = 13 Then
        If Not Dic.exists(UCase(Me.ComboBox2.Text)) Then Me.ComboBox2.Text = ""
        Range("L25").Activate
    End If
End Sub
 
Thử code
Mã:
Option Explicit
Dim Dic As Object
Private Sub Worksheet_Activate()
  Dim i As Long, k As Long, sArr(), ikey
  Set Dic = CreateObject("scripting.dictionary")
  With Sheet2
    k = .Range("C1000000").End(xlUp).Row
    If k < 26 Then
      Dic.Add Empty, Empty
    Else
      sArr = .Range("C26:C" & k).Value
      k = UBound(sArr)
      For i = 1 To k
        ikey = UCase(sArr(i, 1))
        If Len(ikey) > 0 Then Dic.Item(ikey) = Empty
      Next i
    End If
  End With

  With Range("L5")
    Me.ComboBox2.Height = .Height + 5
    Me.ComboBox2.Width = .Width + 5
    Me.ComboBox2.Top = .Top
    Me.ComboBox2.Left = .Left
    Me.ComboBox2.Font.Size = 22
  End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal vitri As Range)
  Dim KH
  If vitri.Address = "$L$5" Then
    KH = Range("L5").Value
    If KH <> "" Then If Not Dic.exists(KH) Then Range("L5") = ""
    Me.ComboBox2.List = Dic.keys
    Me.ComboBox2.Visible = True
    Me.ComboBox2.Activate
    Me.ComboBox2.Text = KH
  Else
    KH = Me.ComboBox2.Text
    Me.ComboBox2.Visible = False
  End If
End Sub

'COMBOBOX
Private Sub ComboBox2_Change() 'NHAP TEN KHACH HANG TRUC TIEP
    On Error Resume Next
    Dim KH As String, k As Long, tmp
    KH = UCase(Me.ComboBox2.Text)
    If KH = "" Then
      Me.ComboBox2.TopIndex = 0
    ElseIf Not Dic.exists(KH) Then
        KH = "*" & KH & "*"
        k = 0
        For Each tmp In Dic.keys
          If UCase(tmp) Like KH Then
            Me.ComboBox2.TopIndex = k: Exit For
          End If
          k = k + 1
        Next tmp
        Me.ComboBox2.DropDown
    Else
      Range("L5").Value = Me.ComboBox2
    End If
End Sub
Private Sub ComboBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)                         'DOUBLE CLICK CHON
    Me.ComboBox2.DropDown
End Sub
Private Sub ComboBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 'PHIM ENTER CHON
    If KeyCode = 13 Then
        If Not Dic.exists(UCase(Me.ComboBox2.Text)) Then Me.ComboBox2.Text = ""
        Range("L25").Activate
    End If
End Sub

em cảm ơn anh. nhanh hơn hẳn và code không còn lag nữa, nhưng có vấn đề là khi mình tìm ra tên KH gần giống.
Em muốn bấm phím lên xuống để tìm thì danh sách không tự chuyển về KH đầu tiên trong list KH tìm được ạ. Mong a giúp giùm ạ
 
Lần chỉnh sửa cuối:
em cảm ơn anh. nhanh hơn hẳn và code không còn lag nữa, nhưng có vấn đề là khi mình tìm ra tên KH gần giống.
Em muốn bấm phím lên xuống để tìm thì danh sách không tự chuyển về KH đầu tiên trong list KH tìm được ạ. Mong a giúp giùm ạ
Chỉnh lại code
Mã:
Option Explicit
Dim Dic As Object, k As Long
Private Sub Worksheet_Activate()
  Call Add_Dic
End Sub

Private Sub Worksheet_SelectionChange(ByVal vitri As Range)
  Dim KH
  If vitri.Address = "$L$5" Then
    If Dic Is Nothing Then Call Add_Dic
    KH = Range("L5").Value
    If KH <> "" Then If Not Dic.exists(KH) Then Range("L5") = ""
    Me.ComboBox2.List = Dic.keys
    Me.ComboBox2.Visible = True
    Me.ComboBox2.Activate
    Me.ComboBox2.Text = KH
  Else
    If Me.ComboBox2.Visible = True Then Me.ComboBox2.Visible = False
  End If
End Sub

'COMBOBOX
Private Sub ComboBox2_Change() 'NHAP TEN KHACH HANG TRUC TIEP
    On Error Resume Next
    Dim KH As String, tmp
    KH = UCase(Me.ComboBox2.Text)
    If KH = "" Then
      Me.ComboBox2.TopIndex = 0
    ElseIf Not Dic.exists(KH) Then
        KH = "*" & KH & "*"
        k = 0
        For Each tmp In Dic.keys
          If UCase(tmp) Like KH Then
            Me.ComboBox2.TopIndex = k: Exit For
          End If
          k = k + 1
        Next tmp
        Me.ComboBox2.DropDown
    Else
      Range("L5").Value = Me.ComboBox2
    End If
End Sub
Private Sub ComboBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)                         'DOUBLE CLICK CHON
    Me.ComboBox2.DropDown
End Sub
Private Sub ComboBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 'PHIM ENTER CHON
    If KeyCode = 40 Then
      If k > 0 Then
        Me.ComboBox2.ListIndex = k - 1
        k = 0
      End If
    End If
    If KeyCode = 38 Then
      If k > 0 Then
        Me.ComboBox2.ListIndex = k + 1
        k = 0
      End If
    End If
    If KeyCode = 13 Then
        If Not Dic.exists(UCase(Me.ComboBox2.Text)) Then Me.ComboBox2.Text = ""
        Range("L25").Activate
    End If
End Sub
Private Sub Add_Dic()
  Dim i As Long, k As Long, sArr(), ikey
  Set Dic = CreateObject("scripting.dictionary")
  With Sheet2
    k = .Range("C1000000").End(xlUp).Row
    If k < 26 Then
      Dic.Add Empty, Empty
    Else
      sArr = .Range("C26:C" & k).Value
      k = UBound(sArr)
      For i = 1 To k
        ikey = UCase(sArr(i, 1))
        If Len(ikey) > 0 Then Dic.Item(ikey) = Empty
      Next i
    End If
  End With

  With Range("L5")
    Me.ComboBox2.Height = .Height + 5
    Me.ComboBox2.Width = .Width + 5
    Me.ComboBox2.Top = .Top
    Me.ComboBox2.Left = .Left
    Me.ComboBox2.Font.Size = 22
  End With
End Sub
 
Chỉnh lại code
Mã:
Option Explicit
Dim Dic As Object, k As Long
Private Sub Worksheet_Activate()
  Call Add_Dic
End Sub

Private Sub Worksheet_SelectionChange(ByVal vitri As Range)
  Dim KH
  If vitri.Address = "$L$5" Then
    If Dic Is Nothing Then Call Add_Dic
    KH = Range("L5").Value
    If KH <> "" Then If Not Dic.exists(KH) Then Range("L5") = ""
    Me.ComboBox2.List = Dic.keys
    Me.ComboBox2.Visible = True
    Me.ComboBox2.Activate
    Me.ComboBox2.Text = KH
  Else
    If Me.ComboBox2.Visible = True Then Me.ComboBox2.Visible = False
  End If
End Sub

'COMBOBOX
Private Sub ComboBox2_Change() 'NHAP TEN KHACH HANG TRUC TIEP
    On Error Resume Next
    Dim KH As String, tmp
    KH = UCase(Me.ComboBox2.Text)
    If KH = "" Then
      Me.ComboBox2.TopIndex = 0
    ElseIf Not Dic.exists(KH) Then
        KH = "*" & KH & "*"
        k = 0
        For Each tmp In Dic.keys
          If UCase(tmp) Like KH Then
            Me.ComboBox2.TopIndex = k: Exit For
          End If
          k = k + 1
        Next tmp
        Me.ComboBox2.DropDown
    Else
      Range("L5").Value = Me.ComboBox2
    End If
End Sub
Private Sub ComboBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)                         'DOUBLE CLICK CHON
    Me.ComboBox2.DropDown
End Sub
Private Sub ComboBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 'PHIM ENTER CHON
    If KeyCode = 40 Then
      If k > 0 Then
        Me.ComboBox2.ListIndex = k - 1
        k = 0
      End If
    End If
    If KeyCode = 38 Then
      If k > 0 Then
        Me.ComboBox2.ListIndex = k + 1
        k = 0
      End If
    End If
    If KeyCode = 13 Then
        If Not Dic.exists(UCase(Me.ComboBox2.Text)) Then Me.ComboBox2.Text = ""
        Range("L25").Activate
    End If
End Sub
Private Sub Add_Dic()
  Dim i As Long, k As Long, sArr(), ikey
  Set Dic = CreateObject("scripting.dictionary")
  With Sheet2
    k = .Range("C1000000").End(xlUp).Row
    If k < 26 Then
      Dic.Add Empty, Empty
    Else
      sArr = .Range("C26:C" & k).Value
      k = UBound(sArr)
      For i = 1 To k
        ikey = UCase(sArr(i, 1))
        If Len(ikey) > 0 Then Dic.Item(ikey) = Empty
      Next i
    End If
  End With

  With Range("L5")
    Me.ComboBox2.Height = .Height + 5
    Me.ComboBox2.Width = .Width + 5
    Me.ComboBox2.Top = .Top
    Me.ComboBox2.Left = .Left
    Me.ComboBox2.Font.Size = 22
  End With
End Sub
Cảm ơn anh đã giúp ạ. Nhưng sau khi test lại chức năng tìm kiếm lại thấy kết quả tìm kiếm không đúng ạ. Mong anh trợ giúp tiếp giùm e ạ
 

File đính kèm

  • CODE GỐC.png
    CODE GỐC.png
    88.1 KB · Đọc: 29
  • CODE FIX2.png
    CODE FIX2.png
    88.6 KB · Đọc: 31
Nói rỏ không đúng chổ nào
Khi em tìm người tên là NGOC thì sẽ hiện ra tên những người có tên có ký tự gần giống NGOC (hình CODE GỐC),
nhưng khi e thử code Anh viết cho thì không đúng, ra mỗi cái đầu tiên có NGOC, còn mấy cái gần giống lại không có (hình CODE FIX2)
Anh xem giùm e ạ
 
Khi em tìm người tên là NGOC thì sẽ hiện ra tên những người có tên có ký tự gần giống NGOC (hình CODE GỐC),
nhưng khi e thử code Anh viết cho thì không đúng, ra mỗi cái đầu tiên có NGOC, còn mấy cái gần giống lại không có (hình CODE FIX2)
Anh xem giùm e ạ
Cách nhập giá trị dò tìm như thế nào?
1/ Luôn bắt đầu từ ký tự đầu của mã khách hàng "NGO": Code chạy nhanh
2/ Hay ký tự có thứ tự bất kỳ trong mã: Code chạy chậm
 
Ý thứ 2 đó anh. Code chạy chậm là sao vậy anh.
Kiểm tra lại code
Mã:
Option Explicit
Dim Dic As Object, sArr As Variant, khStr As String

Private Sub Worksheet_Activate()
  Call Add_Dic
End Sub

Private Sub Worksheet_SelectionChange(ByVal vitri As Range)
  Dim kh
  If vitri.Address = "$L$5" Then
    If Dic Is Nothing Then Call Add_Dic
    kh = Range("L5").Value
    If kh <> "" Then If Not Dic.exists(kh) Then Range("L5") = ""
    Me.ComboBox2.List = sArr
    Me.ComboBox2.Visible = True
    Me.ComboBox2.Activate
    Me.ComboBox2.Text = kh
    khStr = kh
  Else
    If Me.ComboBox2.Visible = True Then Me.ComboBox2.Visible = False
  End If
End Sub

Private Sub ComboBox2_Change() 'NHAP TEN KHACH HANG TRUC TIEP
    On Error Resume Next
    Dim kh As String, tmp
    kh = UCase(Me.ComboBox2.Text)
    If kh = "" Then
      Me.ComboBox2.List = Dic.keys
      Me.ComboBox2.TopIndex = 0
    ElseIf Not Dic.exists(kh) Then
      If Len(khStr) >= Len(kh) Then sArr = Dic.keys
        khStr = kh
        Call CreateArr
      Me.ComboBox2.List = sArr
      Me.ComboBox2.DropDown
    Else
      Range("L5").Value = Me.ComboBox2
    End If
End Sub

Private Sub ComboBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)                         'DOUBLE CLICK CHON
    Me.ComboBox2.DropDown
End Sub

Private Sub ComboBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) 'PHIM ENTER CHON
    If KeyCode = 40 Then
        Me.ComboBox2.DropDown
    End If
    If KeyCode = 13 Then
        If Not Dic.exists(UCase(Me.ComboBox2.Text)) Then Me.ComboBox2.Text = ""
        Range("L25").Activate
    End If
End Sub

Private Sub CreateArr()
  Dim i As Long, sRow As Long, k As Long
  sRow = UBound(sArr)
  For i = 0 To sRow
    If InStr(1, sArr(i), khStr) Then
      sArr(k) = sArr(i)
      k = k + 1
    End If
  Next i
  If k > 0 Then
    ReDim Preserve sArr(0 To k)
  Else
    sArr = Array("")
  End If
End Sub

Private Sub Add_Dic()
  Dim i As Long, sRow As Long, tmp(), ikey
  Set Dic = CreateObject("scripting.dictionary")
  With Sheet2
    i = .Range("C1000000").End(xlUp).Row
    If i < 26 Then
      Dic.Add Empty, Empty
    Else
      tmp = .Range("C26:C" & i).Value
      .Range("C26:C" & i).Sort .Range("C26"), xlAscending
      sArr = .Range("C26:C" & i).Value
      .Range("C26:C" & i).Value = tmp
      sRow = UBound(sArr)
      For i = 1 To sRow
        ikey = UCase(sArr(i, 1))
        If Len(ikey) > 0 Then Dic.Item(ikey) = Empty
      Next i
    End If
  End With
  Erase tmp
  sArr = Dic.keys
  With Range("L5")
    Me.ComboBox2.Height = .Height + 5
    Me.ComboBox2.Width = .Width + 5
    Me.ComboBox2.Top = .Top
    Me.ComboBox2.Left = .Left
    Me.ComboBox2.Font.Size = 22
  End With
End Sub
 
Kiểm tra lại code
Mã:
      tmp = .Range("C26:C" & i).Value
      .Range("C26:C" & i).Sort .Range("C26"), xlAscending
      sArr = .Range("C26:C" & i).Value
      .Range("C26:C" & i).Value = tmp
      sRow = UBound(sArr)
Cảm ơn anh ạ, code chạy nhanh ạ.
Cho em hỏi thêm, đoạn code này có tác dụng gì ạ?
Trường hợp dữ liệu cần lấy không phải cột mà là hàng thì nên làm thế nào ạ?
Anh giúp em thêm chút với ạ. em cảm ơn
 
Cảm ơn anh ạ, code chạy nhanh ạ.
Cho em hỏi thêm, đoạn code này có tác dụng gì ạ?
Trường hợp dữ liệu cần lấy không phải cột mà là hàng thì nên làm thế nào ạ?
Anh giúp em thêm chút với ạ. em cảm ơn
Code sort Ma khách hàng theo thứ tự, nhìn list đẹp hơn, nếu nhập ký tự dò tìm luôn bắt đầu từ ký tự đầu tiên thì không cần xử lý lại mảng sArr và code nhanh hơn rất nhiều
 
Code sort Ma khách hàng theo thứ tự, nhìn list đẹp hơn, nếu nhập ký tự dò tìm luôn bắt đầu từ ký tự đầu tiên thì không cần xử lý lại mảng sArr và code nhanh hơn rất nhiều
dạ anh. Cho em hỏi thêm
Để áp dụng cho trường hợp khác
Trường hợp dữ liệu cần lấy không phải cột mà là hàng thì nên làm thế nào ạ?
Lấy dữ liệu từ D25 đến I25 và gán cào list thì sửa lại như thế nào ạ?
 
dạ anh. Cho em hỏi thêm
Để áp dụng cho trường hợp khác
Trường hợp dữ liệu cần lấy không phải cột mà là hàng thì nên làm thế nào ạ?
Lấy dữ liệu từ D25 đến I25 và gán cào list thì sửa lại như thế nào ạ?
List lấy theo dòng, nên cần chuyển cột thành dòng
Ví dụ
Mã:
    With Sheet2
      sArr = Application.Transpose(.Range("D25:I25").Value)
    End With
    Me.ComboBox2.List = sArr
 
Web KT
Back
Top Bottom