Giúp code lọc dữ liệu siêu tốc khoảng 10.000 dòng (1 người xem)

minhtuan55 · 8/11/17

Chào cả nhà GPE!
Em đang cần làm 1 đoạn code để lọc dữ liệu khoảng 10.000 dòng trở xuống ( code khi đánh vài ký tự liên quan trong Textbox thì Listbox sẽ hiện ra kết quả ( Trong Form)). Hiện em đang dùng code cũng ở trên diễn đàn
Nhưng nó xứ lý chỉ được 500 dòng là OK mà 10.000 dòng thì như rùa bò luôn. Mong các cao thủ giúp em. XIn chân thành cảm ơn !

Mã:

Sub locnhapkhonewa()
 On Error Resume Next
Dim dl(), i As Long
dl = Sheets("khachhang").Range("K4:K5003").Value 'lay nguon hang hoa
THANHTOAN.ListBox1.Clear
For i = 1 To UBound(dl)
   If dl(i, 1) <> "" Then
      If TV(UCase(dl(i, 1))) Like "*" & TV(UCase(THANHTOAN.TextBox1.Value)) & "*" Then ' dieu kien loc Bo dau tieng viet Chu hoa chu thuong
         THANHTOAN.ListBox1.AddItem dl(i, 1)
      End If
   End If
Next
End Sub



Function TV(ByVal Text As String) As String ' bo dau tieng viet
  Dim CharCode, ResText As String, i As Long, tmp As String
  On Error Resume Next
  tmp = Text
  CharCode = Array(ChrW(7855), ChrW(7857), ChrW(7859), ChrW(7861), ChrW(7863), ChrW(7845), ChrW(7847), _
                   ChrW(7849), ChrW(7851), ChrW(7853), ChrW(225), ChrW(224), ChrW(7843), ChrW(227), ChrW(7841), _
                   ChrW(259), ChrW(226), ChrW(273), ChrW(7871), ChrW(7873), ChrW(7875), ChrW(7877), ChrW(7879), _
                   ChrW(233), ChrW(232), ChrW(7867), ChrW(7869), ChrW(7865), ChrW(234), ChrW(237), ChrW(236), _
                   ChrW(7881), ChrW(297), ChrW(7883), ChrW(7889), ChrW(7891), ChrW(7893), ChrW(7895), ChrW(7897), _
                   ChrW(7899), ChrW(7901), ChrW(7903), ChrW(7905), ChrW(7907), ChrW(243), ChrW(242), ChrW(7887), _
                   ChrW(245), ChrW(7885), ChrW(244), ChrW(417), ChrW(7913), ChrW(7915), ChrW(7917), ChrW(7919), _
                   ChrW(7921), ChrW(250), ChrW(249), ChrW(7911), ChrW(361), ChrW(7909), ChrW(432), ChrW(253), _
                   ChrW(7923), ChrW(7927), ChrW(7929), ChrW(7925))
  ResText = "aaaaaaaaaaaaaaaaadeeeeeeeeeeeiiiiiooooooooooooooooouuuuuuuuuuuyyyyy"
  For i = 0 To UBound(CharCode)
    tmp = Replace(tmp, CharCode(i), Mid(ResText, i + 1, 1))
    tmp = Replace(tmp, UCase(CharCode(i)), UCase(Mid(ResText, i + 1, 1)))
  Next
  TV = tmp
End Function



Private Sub TextBox1_Change()
locnhapkhonewa
End Sub

huuthang_bd · 8/11/17

Tạo mảng dữ liệu không dấu khi form được gọi và khi lọc so sánh với dữ liệu này.
Ngoài ra ghi kết quả vào mảng sau đó gán vào listbox 1 lần (.List) có thể sẽ nhanh hơn AddItem từng kết quả.

minhtuan55 · 9/11/17

Dạ em cảm ơn anh. Em chỉ biết Code sơ sơ thôi ak, Em toàn lấy code diễn dàn em thay địa chỉ đầu vào đầu ra thôi. Chứ em không biết viết. Mong anh giúp em. Chứ em không biết Mãng hay AddItem gì hết

huuthang_bd đã viết:
Tạo mảng dữ liệu không dấu khi form được gọi và khi lọc so sánh với dữ liệu này.
Ngoài ra ghi kết quả vào mảng sau đó gán vào listbox 1 lần (.List) có thể sẽ nhanh hơn AddItem từng kết quả.

ndu96081631 · 9/11/17

minhtuan55 đã viết:
Chào cả nhà GPE!
Em đang cần làm 1 đoạn code để lọc dữ liệu khoảng 10.000 dòng trở xuống

Vậy file 10,000 dòng dữ liệu của bạn đâu?

HieuCD · 9/11/17

minhtuan55 đã viết:

Chào cả nhà GPE!
Em đang cần làm 1 đoạn code để lọc dữ liệu khoảng 10.000 dòng trở xuống ( code khi đánh vài ký tự liên quan trong Textbox thì Listbox sẽ hiện ra kết quả ( Trong Form)). Hiện em đang dùng code cũng ở trên diễn đàn
Nhưng nó xứ lý chỉ được 500 dòng là OK mà 10.000 dòng thì như rùa bò luôn. Mong các cao thủ giúp em. XIn chân thành cảm ơn !

Mã:

Sub locnhapkhonewa()
 On Error Resume Next
Dim dl(), i As Long
dl = Sheets("khachhang").Range("K4:K5003").Value 'lay nguon hang hoa
THANHTOAN.ListBox1.Clear
For i = 1 To UBound(dl)
   If dl(i, 1) <> "" Then
      If TV(UCase(dl(i, 1))) Like "*" & TV(UCase(THANHTOAN.TextBox1.Value)) & "*" Then ' dieu kien loc Bo dau tieng viet Chu hoa chu thuong
         THANHTOAN.ListBox1.AddItem dl(i, 1)
      End If
   End If
Next
End Sub



Function TV(ByVal Text As String) As String ' bo dau tieng viet
  Dim CharCode, ResText As String, i As Long, tmp As String
  On Error Resume Next
  tmp = Text
  CharCode = Array(ChrW(7855), ChrW(7857), ChrW(7859), ChrW(7861), ChrW(7863), ChrW(7845), ChrW(7847), _
                   ChrW(7849), ChrW(7851), ChrW(7853), ChrW(225), ChrW(224), ChrW(7843), ChrW(227), ChrW(7841), _
                   ChrW(259), ChrW(226), ChrW(273), ChrW(7871), ChrW(7873), ChrW(7875), ChrW(7877), ChrW(7879), _
                   ChrW(233), ChrW(232), ChrW(7867), ChrW(7869), ChrW(7865), ChrW(234), ChrW(237), ChrW(236), _
                   ChrW(7881), ChrW(297), ChrW(7883), ChrW(7889), ChrW(7891), ChrW(7893), ChrW(7895), ChrW(7897), _
                   ChrW(7899), ChrW(7901), ChrW(7903), ChrW(7905), ChrW(7907), ChrW(243), ChrW(242), ChrW(7887), _
                   ChrW(245), ChrW(7885), ChrW(244), ChrW(417), ChrW(7913), ChrW(7915), ChrW(7917), ChrW(7919), _
                   ChrW(7921), ChrW(250), ChrW(249), ChrW(7911), ChrW(361), ChrW(7909), ChrW(432), ChrW(253), _
                   ChrW(7923), ChrW(7927), ChrW(7929), ChrW(7925))
  ResText = "aaaaaaaaaaaaaaaaadeeeeeeeeeeeiiiiiooooooooooooooooouuuuuuuuuuuyyyyy"
  For i = 0 To UBound(CharCode)
    tmp = Replace(tmp, CharCode(i), Mid(ResText, i + 1, 1))
    tmp = Replace(tmp, UCase(CharCode(i)), UCase(Mid(ResText, i + 1, 1)))
  Next
  TV = tmp
End Function



Private Sub TextBox1_Change()
locnhapkhonewa
End Sub

thử code

Mã:

Dim dic As Object, Test As Boolean
Private Sub locnhapkhonewa()
On Error Resume Next
Dim dl(), arr(), i As Long, dk As String, tmp As String
dl = Sheets("khachhang").Range("K4:K5003").Value 'lay nguon hang hoa
dk = Up_TV_KhongDau(UCase(TextBox1.Value))
ReDim arr(1 To 1)
ListBox1.Clear
For i = 1 To UBound(dl)
   If dl(i, 1) <> "" Then
      tmp = Up_TV_KhongDau(UCase(dl(i, 1)))
      If tmp Like "*" & dk & "*" Then ' dieu kien loc Bo dau tieng viet Chu hoa chu thuong
          k = k + 1
          ReDim Preserve arr(1 To k)
          arr(k) = tmp
      End If
   End If
Next
ListBox1.List = arr
End Sub
Private Function Up_TV_KhongDau(ByVal Text As String) As String ' bo dau tieng viet
  Dim CharCode, ResText As String, i As Long, tmp As String
  On Error Resume Next
  If Len(Text) = 0 Then Up_TV_KhongDau = "": Exit Function
  If Test = False Then
    Set dic = CreateObject("scripting.dictionary")
    CharCode = Array(ChrW(7855), ChrW(7857), ChrW(7859), ChrW(7861), ChrW(7863), ChrW(7845), ChrW(7847), _
                   ChrW(7849), ChrW(7851), ChrW(7853), ChrW(225), ChrW(224), ChrW(7843), ChrW(227), ChrW(7841), _
                   ChrW(259), ChrW(226), ChrW(273), ChrW(7871), ChrW(7873), ChrW(7875), ChrW(7877), ChrW(7879), _
                   ChrW(233), ChrW(232), ChrW(7867), ChrW(7869), ChrW(7865), ChrW(234), ChrW(237), ChrW(236), _
                   ChrW(7881), ChrW(297), ChrW(7883), ChrW(7889), ChrW(7891), ChrW(7893), ChrW(7895), ChrW(7897), _
                   ChrW(7899), ChrW(7901), ChrW(7903), ChrW(7905), ChrW(7907), ChrW(243), ChrW(242), ChrW(7887), _
                   ChrW(245), ChrW(7885), ChrW(244), ChrW(417), ChrW(7913), ChrW(7915), ChrW(7917), ChrW(7919), _
                   ChrW(7921), ChrW(250), ChrW(249), ChrW(7911), ChrW(361), ChrW(7909), ChrW(432), ChrW(253), _
                   ChrW(7923), ChrW(7927), ChrW(7929), ChrW(7925))
    ResText = "aaaaaaaaaaaaaaaaadeeeeeeeeeeeiiiiiooooooooooooooooouuuuuuuuuuuyyyyy"
    For i = 0 To UBound(CharCode)
      dic.Add CharCode(i), Mid(ResText, i + 1, 1)
      dic.Add UCase(CharCode(i)), UCase(Mid(ResText, i + 1, 1))
    Next
    Test = True
  End If
  For i = 1 To Len(Text)
    Key = Mid(Text, i, 1)
    If dic.Exit(Key) Then Mid(Text, i, 1) = dic.Item(Key)
  Next
  Up_TV_KhongDau = Text
End Function
Private Sub TextBox1_Change()
  locnhapkhonewa
End Sub

minhtuan55 · 13/11/17

ndu96081631 đã viết:
Vậy file 10,000 dòng dữ liệu của bạn đâu?

Gửi anh

be_09 · 14/11/17

minhtuan55 đã viết:
Gửi anh

Xem thử.
Lưu ý:
- Gõ ký tự bất kỳ thì nó sẽ tìm chữ đầu tiên bên trái.
- Muốn tìm bất kỳ thì gõ ký tự * (dấu Sao) rồi gõ từ muốn tìm kế tiếp.

ndu96081631 · 14/11/17

minhtuan55 đã viết:
Gửi anh

Để tăng tốc code, tôi đề nghị tạo 1 biến chứa dữ liệu đã loại bỏ dấu tiếng Việt. Biến này là biến toàn cục và được load ngay khi mở file (Aut

pen) đồng thời cũng có thể được khởi tạo lại khi có thay đổi trên sheet (sự kiện Change)
Vậy chúng ta phải chấp nhận file bị chậm khi vừa mới khởi động (đương nhiên sau đó sẽ nhanh)
Toàn bộ code đề xuất:
1> Trong Module:

Mã:

Public rngSrc As Range, aDes, bChk As Boolean
Sub Auto_Open()
  Dim aSrc
  Dim lR As Long
  Set rngSrc = Sheet1.Range("B4:B20000")
  aSrc = rngSrc.Value
  aDes = aSrc
  ReDim Preserve aDes(1 To UBound(aDes, 1), 1 To 2)
  For lR = 1 To UBound(aSrc, 1)
    aDes(lR, 2) = RemoveMarks(aDes(lR, 1))
  Next
End Sub
Function RemoveMarks(ByVal Text As String) As String
  Dim CharCode, i As Long
  Dim ResText As String, sTmp As String
  On Error Resume Next
  sTmp = Text
  CharCode = Array(7855, 7857, 7859, 7861, 7863, 7845, 7847, 7849, 7851, 7853, 225, _
                   224, 7843, 227, 7841, 259, 226, 273, 7871, 7873, 7875, 7877, 7879, _
                   233, 232, 7867, 7869, 7865, 234, 237, 236, 7881, 297, 7883, 7889, _
                   7891, 7893, 7895, 7897, 7899, 7901, 7903, 7905, 7907, 243, 242, _
                   7887, 245, 7885, 244, 417, 7913, 7915, 7917, 7919, 7921, 250, _
                   249, 7911, 361, 7909, 432, 253, 7923, 7927, 7929, 7925)
  ResText = "aaaaaaaaaaaaaaaaadeeeeeeeeeeeiiiiiooooooooooooooooouuuuuuuuuuuyyyyy"
  For i = 0 To UBound(CharCode)
    sTmp = Replace(sTmp, ChrW(CharCode(i)), Mid(ResText, i + 1, 1))
    sTmp = Replace(sTmp, UCase(ChrW(CharCode(i))), UCase(Mid(ResText, i + 1, 1)))
  Next
  RemoveMarks = sTmp
End Function
Function Filter2DArray(ByVal SourceArray, ByVal ColIndex As Long, ByVal FindStr As String, ByVal HasTitle As Boolean)
  Dim aTmpArr, i As Long, j As Long, arr, dic, TmpStr, Tmp, Chk As Boolean, TmpVal As Double
  On Error Resume Next
  Set dic = CreateObject("Scripting.Dictionary")
  aTmpArr = SourceArray
  ColIndex = ColIndex + LBound(aTmpArr, 2) - 1
  Chk = (InStr("><=", Left(FindStr, 1)) > 0)
  For i = LBound(aTmpArr, 1) - HasTitle To UBound(aTmpArr, 1)
    If Chk And FindStr <> "" Then
      TmpVal = CDbl(aTmpArr(i, ColIndex))
      If Evaluate(TmpVal & FindStr) Then dic.Add i, ""
    Else
      If Left(FindStr, 1) = "!" Then
        If Not (UCase(aTmpArr(i, ColIndex)) Like UCase(Mid(FindStr, 2, Len(FindStr)))) Then dic.Add i, ""
      Else
        If UCase(aTmpArr(i, ColIndex)) Like UCase(FindStr) Then dic.Add i, ""
      End If
    End If
  Next
  If dic.Count > 0 Then
    Tmp = dic.Keys
    ReDim arr(LBound(aTmpArr, 1) To UBound(Tmp) + LBound(aTmpArr, 1) - HasTitle, LBound(aTmpArr, 2) To UBound(aTmpArr, 2))
    For i = LBound(aTmpArr, 1) - HasTitle To UBound(Tmp) + LBound(aTmpArr, 1) - HasTitle
      For j = LBound(aTmpArr, 2) To UBound(aTmpArr, 2)
        arr(i, j) = aTmpArr(Tmp(i - LBound(aTmpArr, 1) + HasTitle), j)
      Next
    Next
    If HasTitle Then
      For j = LBound(aTmpArr, 2) To UBound(aTmpArr, 2)
        arr(LBound(aTmpArr, 1), j) = aTmpArr(LBound(aTmpArr, 1), j)
      Next
    End If
  End If
  Filter2DArray = arr
End Function
Sub fesrtg()
UserForm1.Show
End Sub

2> Trong UserForm:

Mã:

Private Sub TextBox1_Change()
  Dim arr
  arr = Filter2DArray(aDes, 2, "*" & RemoveMarks(TextBox1.Text) & "*", False)
  If IsArray(arr) Then Me.ListBox1.List = arr
End Sub
Private Sub UserForm_Initialize()
  If (rngSrc Is Nothing) Or bChk Then
    Auto_Open
    bChk = False
  End If
End Sub

3> Trong sự kiện Change của sheet:

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Range("B4:B20000"), Target) Is Nothing Then bChk = True
End Sub

Mời tham khảo file đính kèm

minhtuan55 · 18/11/17

ndu96081631 đã viết:

Để tăng tốc code, tôi đề nghị tạo 1 biến chứa dữ liệu đã loại bỏ dấu tiếng Việt. Biến này là biến toàn cục và được load ngay khi mở file (Aut

pen) đồng thời cũng có thể được khởi tạo lại khi có thay đổi trên sheet (sự kiện Change)
Vậy chúng ta phải chấp nhận file bị chậm khi vừa mới khởi động (đương nhiên sau đó sẽ nhanh)
Toàn bộ code đề xuất:
1> Trong Module:

Mã:

Public rngSrc As Range, aDes, bChk As Boolean
Sub Auto_Open()
  Dim aSrc
  Dim lR As Long
  Set rngSrc = Sheet1.Range("B4:B20000")
  aSrc = rngSrc.Value
  aDes = aSrc
  ReDim Preserve aDes(1 To UBound(aDes, 1), 1 To 2)
  For lR = 1 To UBound(aSrc, 1)
    aDes(lR, 2) = RemoveMarks(aDes(lR, 1))
  Next
End Sub
Function RemoveMarks(ByVal Text As String) As String
  Dim CharCode, i As Long
  Dim ResText As String, sTmp As String
  On Error Resume Next
  sTmp = Text
  CharCode = Array(7855, 7857, 7859, 7861, 7863, 7845, 7847, 7849, 7851, 7853, 225, _
                   224, 7843, 227, 7841, 259, 226, 273, 7871, 7873, 7875, 7877, 7879, _
                   233, 232, 7867, 7869, 7865, 234, 237, 236, 7881, 297, 7883, 7889, _
                   7891, 7893, 7895, 7897, 7899, 7901, 7903, 7905, 7907, 243, 242, _
                   7887, 245, 7885, 244, 417, 7913, 7915, 7917, 7919, 7921, 250, _
                   249, 7911, 361, 7909, 432, 253, 7923, 7927, 7929, 7925)
  ResText = "aaaaaaaaaaaaaaaaadeeeeeeeeeeeiiiiiooooooooooooooooouuuuuuuuuuuyyyyy"
  For i = 0 To UBound(CharCode)
    sTmp = Replace(sTmp, ChrW(CharCode(i)), Mid(ResText, i + 1, 1))
    sTmp = Replace(sTmp, UCase(ChrW(CharCode(i))), UCase(Mid(ResText, i + 1, 1)))
  Next
  RemoveMarks = sTmp
End Function
Function Filter2DArray(ByVal SourceArray, ByVal ColIndex As Long, ByVal FindStr As String, ByVal HasTitle As Boolean)
  Dim aTmpArr, i As Long, j As Long, arr, dic, TmpStr, Tmp, Chk As Boolean, TmpVal As Double
  On Error Resume Next
  Set dic = CreateObject("Scripting.Dictionary")
  aTmpArr = SourceArray
  ColIndex = ColIndex + LBound(aTmpArr, 2) - 1
  Chk = (InStr("><=", Left(FindStr, 1)) > 0)
  For i = LBound(aTmpArr, 1) - HasTitle To UBound(aTmpArr, 1)
    If Chk And FindStr <> "" Then
      TmpVal = CDbl(aTmpArr(i, ColIndex))
      If Evaluate(TmpVal & FindStr) Then dic.Add i, ""
    Else
      If Left(FindStr, 1) = "!" Then
        If Not (UCase(aTmpArr(i, ColIndex)) Like UCase(Mid(FindStr, 2, Len(FindStr)))) Then dic.Add i, ""
      Else
        If UCase(aTmpArr(i, ColIndex)) Like UCase(FindStr) Then dic.Add i, ""
      End If
    End If
  Next
  If dic.Count > 0 Then
    Tmp = dic.Keys
    ReDim arr(LBound(aTmpArr, 1) To UBound(Tmp) + LBound(aTmpArr, 1) - HasTitle, LBound(aTmpArr, 2) To UBound(aTmpArr, 2))
    For i = LBound(aTmpArr, 1) - HasTitle To UBound(Tmp) + LBound(aTmpArr, 1) - HasTitle
      For j = LBound(aTmpArr, 2) To UBound(aTmpArr, 2)
        arr(i, j) = aTmpArr(Tmp(i - LBound(aTmpArr, 1) + HasTitle), j)
      Next
    Next
    If HasTitle Then
      For j = LBound(aTmpArr, 2) To UBound(aTmpArr, 2)
        arr(LBound(aTmpArr, 1), j) = aTmpArr(LBound(aTmpArr, 1), j)
      Next
    End If
  End If
  Filter2DArray = arr
End Function
Sub fesrtg()
UserForm1.Show
End Sub

2> Trong UserForm:

Mã:

Private Sub TextBox1_Change()
  Dim arr
  arr = Filter2DArray(aDes, 2, "*" & RemoveMarks(TextBox1.Text) & "*", False)
  If IsArray(arr) Then Me.ListBox1.List = arr
End Sub
Private Sub UserForm_Initialize()
  If (rngSrc Is Nothing) Or bChk Then
    Auto_Open
    bChk = False
  End If
End Sub

3> Trong sự kiện Change của sheet:

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Range("B4:B20000"), Target) Is Nothing Then bChk = True
End Sub

Mời tham khảo file đính kèm

COde quá OK xin chân thành cảm ơn anh

minhtuan55 · 18/11/17

be09 đã viết:
Xem thử.
Lưu ý:
- Gõ ký tự bất kỳ thì nó sẽ tìm chữ đầu tiên bên trái.
- Muốn tìm bất kỳ thì gõ ký tự * (dấu Sao) rồi gõ từ muốn tìm kế tiếp.

Cảm ơn anh nhiều. Code rất OK tuy chậm 1 tí như vậy là ok rồi

Nguyễn Duy Tuân · 18/11/17

minhtuan55 đã viết:
Cảm ơn anh nhiều. Code rất OK tuy chậm 1 tí như vậy là ok rồi

Tôi thấy code đó là nhanh rồi đấy. Nếu có cái khác thì chỉ hơn không đáng kể đâu.

tamtam333 · 18/11/17

Nếu cần nhanh hơn nữa, thì nên sử dụng ngôn ngữ lập trình khác (tạo file thực thi) thay vì VBA trong EXCEL

Hoang2013 · 19/11/17

Mình xin được hỏi chủ bài đăng:

Thực chất trong file của bạn là cần "lọc" cái gì sau đây:

Lọc họ tên?
Lọc tên hàng hóa;
Lọc tên đầu sách?
Hay lọc cái gì khác nữa.

Hỏi như thế vì có khi bạn tạo bộ mã cho trường cần lọc thì sẽ là chuyện khác.

Chúc mọi người cuối tuần vui vẻ!

Nguyễn Duy Tuân · 19/11/17

tamtam333 đã viết:
Nếu cần nhanh hơn nữa, thì nên sử dụng ngôn ngữ lập trình khác (tạo file thực thi) thay vì VBA trong EXCEL

Tùy cái mới nhanh nhé. Vụ làm mảng trong VBA khá nhanh, đặc biệt cái listBox của VBA load data vào LIST cực nhanh. Bạn không thể làm nhanh hơn với ngôn ngữ khác so với kiểu làm VBA với cahs làm mảng. Nếu tôi sai thì bạn chứng minh xem.

batman1 · 19/11/17

Nguyễn Duy Tuân đã viết:
Tôi thấy code đó là nhanh rồi đấy. Nếu có cái khác thì chỉ hơn không đáng kể đâu.

Về nguyên tắc, nhất là khi dữ liệu cực lớn, những cái gì cần làm 1 lần thì không đặt trong vòng lặp.
Tức thay cho

Mã:

For i = 1 To UBound(x, 1)
                If LCase(x(i, 1)) Like LCase(TextBox1) & "*" Then

thì nên có

Mã:

mask = LCase(TextBox1) & "*"
For i = 1 To UBound(x, 1)
    If LCase(x(i, 1)) Like mask Then

"Lờ" nguyên tắc chỉ nên chấp nhận khi vòng lặp nhỏ.

Với dữ liệu nhiều (nhiều dòng thỏa) thì không nên dùng AddItem mà ghi vào mảng rồi nhập vào List (hoặc Column tùy theo mảng kia thế nào)

Đây chỉ là ý kiến chủ quan.

Nguyễn Duy Tuân · 19/11/17

batman1 đã viết:
Về nguyên tắc, nhất là khi dữ liệu cực lớn, những cái gì cần làm 1 lần thì không đặt trong vòng lặp.
Tức thay cho

Mã:

For i = 1 To UBound(x, 1) If LCase(x(i, 1)) Like LCase(TextBox1) & "*" Then

thì nên có

Mã:

mask = LCase(TextBox1) & "*" For i = 1 To UBound(x, 1) If LCase(x(i, 1)) Like mask Then

"Lờ" nguyên tắc chỉ nên chấp nhận khi vòng lặp nhỏ.

Với dữ liệu nhiều (nhiều dòng thỏa) thì không nên dùng AddItem mà ghi vào mảng rồi nhập vào List (hoặc Column tùy theo mảng kia thế nào)

Đây chỉ là ý kiến chủ quan.

ĐÚng rồi anh. Mọi thứ phải giải quyết triệt để trước khi đưa vào vòng lặp. Code còn phải tỉa tót hơn nữa thì mới thực sự ngon, kể cả khi thêm nhiều điêu kiện.... Ý em nhanh ở đây là tổng thể - Chủ thớt không mong đợi quá tốt hơn được .

NGOCTOAN · 19/11/17

Chào Bác Ndu, theo file của Bác gửi cho em hỏi khi lọc ra List trên form mình cho con chỏ đến dòng đã chọn làm sao để gán vào 1 cell của 1 sheet hiện hành ạ.
Ngoctoan.

ndu96081631 đã viết:

Để tăng tốc code, tôi đề nghị tạo 1 biến chứa dữ liệu đã loại bỏ dấu tiếng Việt. Biến này là biến toàn cục và được load ngay khi mở file (Aut

pen) đồng thời cũng có thể được khởi tạo lại khi có thay đổi trên sheet (sự kiện Change)
Vậy chúng ta phải chấp nhận file bị chậm khi vừa mới khởi động (đương nhiên sau đó sẽ nhanh)
Toàn bộ code đề xuất:
1> Trong Module:

Mã:

Public rngSrc As Range, aDes, bChk As Boolean
Sub Auto_Open()
  Dim aSrc
  Dim lR As Long
  Set rngSrc = Sheet1.Range("B4:B20000")
  aSrc = rngSrc.Value
  aDes = aSrc
  ReDim Preserve aDes(1 To UBound(aDes, 1), 1 To 2)
  For lR = 1 To UBound(aSrc, 1)
    aDes(lR, 2) = RemoveMarks(aDes(lR, 1))
  Next
End Sub
Function RemoveMarks(ByVal Text As String) As String
  Dim CharCode, i As Long
  Dim ResText As String, sTmp As String
  On Error Resume Next
  sTmp = Text
  CharCode = Array(7855, 7857, 7859, 7861, 7863, 7845, 7847, 7849, 7851, 7853, 225, _
                   224, 7843, 227, 7841, 259, 226, 273, 7871, 7873, 7875, 7877, 7879, _
                   233, 232, 7867, 7869, 7865, 234, 237, 236, 7881, 297, 7883, 7889, _
                   7891, 7893, 7895, 7897, 7899, 7901, 7903, 7905, 7907, 243, 242, _
                   7887, 245, 7885, 244, 417, 7913, 7915, 7917, 7919, 7921, 250, _
                   249, 7911, 361, 7909, 432, 253, 7923, 7927, 7929, 7925)
  ResText = "aaaaaaaaaaaaaaaaadeeeeeeeeeeeiiiiiooooooooooooooooouuuuuuuuuuuyyyyy"
  For i = 0 To UBound(CharCode)
    sTmp = Replace(sTmp, ChrW(CharCode(i)), Mid(ResText, i + 1, 1))
    sTmp = Replace(sTmp, UCase(ChrW(CharCode(i))), UCase(Mid(ResText, i + 1, 1)))
  Next
  RemoveMarks = sTmp
End Function
Function Filter2DArray(ByVal SourceArray, ByVal ColIndex As Long, ByVal FindStr As String, ByVal HasTitle As Boolean)
  Dim aTmpArr, i As Long, j As Long, arr, dic, TmpStr, Tmp, Chk As Boolean, TmpVal As Double
  On Error Resume Next
  Set dic = CreateObject("Scripting.Dictionary")
  aTmpArr = SourceArray
  ColIndex = ColIndex + LBound(aTmpArr, 2) - 1
  Chk = (InStr("><=", Left(FindStr, 1)) > 0)
  For i = LBound(aTmpArr, 1) - HasTitle To UBound(aTmpArr, 1)
    If Chk And FindStr <> "" Then
      TmpVal = CDbl(aTmpArr(i, ColIndex))
      If Evaluate(TmpVal & FindStr) Then dic.Add i, ""
    Else
      If Left(FindStr, 1) = "!" Then
        If Not (UCase(aTmpArr(i, ColIndex)) Like UCase(Mid(FindStr, 2, Len(FindStr)))) Then dic.Add i, ""
      Else
        If UCase(aTmpArr(i, ColIndex)) Like UCase(FindStr) Then dic.Add i, ""
      End If
    End If
  Next
  If dic.Count > 0 Then
    Tmp = dic.Keys
    ReDim arr(LBound(aTmpArr, 1) To UBound(Tmp) + LBound(aTmpArr, 1) - HasTitle, LBound(aTmpArr, 2) To UBound(aTmpArr, 2))
    For i = LBound(aTmpArr, 1) - HasTitle To UBound(Tmp) + LBound(aTmpArr, 1) - HasTitle
      For j = LBound(aTmpArr, 2) To UBound(aTmpArr, 2)
        arr(i, j) = aTmpArr(Tmp(i - LBound(aTmpArr, 1) + HasTitle), j)
      Next
    Next
    If HasTitle Then
      For j = LBound(aTmpArr, 2) To UBound(aTmpArr, 2)
        arr(LBound(aTmpArr, 1), j) = aTmpArr(LBound(aTmpArr, 1), j)
      Next
    End If
  End If
  Filter2DArray = arr
End Function
Sub fesrtg()
UserForm1.Show
End Sub

2> Trong UserForm:

Mã:

Private Sub TextBox1_Change()
  Dim arr
  arr = Filter2DArray(aDes, 2, "*" & RemoveMarks(TextBox1.Text) & "*", False)
  If IsArray(arr) Then Me.ListBox1.List = arr
End Sub
Private Sub UserForm_Initialize()
  If (rngSrc Is Nothing) Or bChk Then
    Auto_Open
    bChk = False
  End If
End Sub

3> Trong sự kiện Change của sheet:

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Range("B4:B20000"), Target) Is Nothing Then bChk = True
End Sub

Mời tham khảo file đính kèm

Hamedanger · 19/11/17

Nguyễn Duy Tuân đã viết:
Tùy cái mới nhanh nhé. Vụ làm mảng trong VBA khá nhanh, đặc biệt cái listBox của VBA load data vào LIST cực nhanh. Bạn không thể làm nhanh hơn với ngôn ngữ khác so với kiểu làm VBA với cahs làm mảng. Nếu tôi sai thì bạn chứng minh xem.

Công nhận với a là cái .list của listbox này nhanh thật , e thử dùng ado chuyển sang mảng rồi nạp vào .list và nâng dữ liệu lên hơn 60k dòng, tốc độ trên máy e là chấp nhận được CoreI5 2540M - 3GB ram dù vẫn màn hình hơi khựng lại chút xíu không đáng kể.

Đã test lại vẫn chậm hơn so với thầy NDU

HieuCD · 19/11/17

Hamedanger đã viết:
Công nhận với a là cái .list của listbox này nhanh thật , e thử dùng ado chuyển sang mảng rồi nạp vào .list và nâng dữ liệu lên hơn 60k dòng, tốc độ trên máy e là chấp nhận được CoreI5 2540M - 3GB ram dù vẫn màn hình hơi khựng lại chút xíu không đáng kể.

Đã test lại vẫn chậm hơn so với thầy NDU

Muốn nhanh thì dùng Dic kết hợp với mảng

Hoang2013 · 20/11/17

Muốn nhanh thì dùng Dic kết hợp với mảng

Mình nhập từ 'Chá' thì hiện ra danh sách liệt kê;
Nhưng nhập nối tiếp thêm chữ 'o' thì danh sách trống trơn, là sao ta?
Rõ ràng trước đó trong danh sách hiển thị rất nhiều dòng có từ 'cháo' mà!

HieuCD · 20/11/17

Hoang2013 đã viết:
Mình nhập từ 'Chá' thì hiện ra danh sách liệt kê;
Nhưng nhập nối tiếp thêm chữ 'o' thì danh sách trống trơn, là sao ta?
Rõ ràng trước đó trong danh sách hiển thị rất nhiều dòng có từ 'cháo' mà!

Do thiếu dòng lệnh bỏ dấu trong sub
tmp = Up_TV_KhongDau(tmp)

Mã:

Private Sub Add_Data()
  Dim dArr As Variant, tmp As String, key As String, i As Long, j As Integer
  i = Sheets("Sheet1").Range("B65500").End(xlUp).Row
  dArr = Sheets("Sheet1").Range("B4:B" & i).Value
  ReDim Sarr(1 To UBound(dArr), 1 To 2)
  For i = 1 To UBound(dArr)
    tmp = UCase(dArr(i, 1))
    If tmp <> "" Then
      tmp = Up_TV_KhongDau(tmp)
      For j = 1 To Len(tmp)
        key = Mid(tmp, i, 1)
        If dic.Exists(key) Then Mid(tmp, i, 1) = dic.Item(key)
      Next
      Sarr(i, 1) = tmp
      Sarr(i, 2) = dArr(i, 1)
    End If
  Next i
End Sub

Hamedanger · 20/11/17

HieuCD đã viết:
Do thiếu dòng lệnh bỏ dấu trong sub
tmp = Up_TV_KhongDau(tmp)

Code của a nhanh nhất nhưng lại ko chính xác anh ạ, ví dụ tìm cáo từ : áo , ân , è .... thì hiển thị luôn những thứ chẳng liên quan gì

HieuCD · 20/11/17

Hamedanger đã viết:
Code của a nhanh nhất nhưng lại ko chính xác anh ạ, ví dụ tìm cáo từ : áo , ân , è .... thì hiển thị luôn những thứ chẳng liên quan gì

Những từ vu vơ không có mục đích, không có ý nghĩa gì thì tìm làm chi vậy?

SA_DQ · 20/11/17

Mình cho là vầy:
Khi nhập vô TextBox từ 'Chá', VBE vẫn đi tìm các từ trong dòng có "cha" & là có tìm thấy;
Nhưng từ 'Cháo' mà ta nhập vô TextBox nó đã bị xóa dấu sắc đi rồi; Nó đi tìm từ "Chao"; Bạn nào thữ thêm từ 'Chao' trong cột dữ liệu xem sao?

Mình thử như thế này:
Nhập chữ 'Cháy' vô 1 ô trang tính & chép lên TextBox, thì nó tìm chữ 'chay' & cả chữ 'cháy'

Hamedanger · 20/11/17

HieuCD đã viết:
Những từ vu vơ không có mục đích, không có ý nghĩa gì thì tìm làm chi vậy?

E góp ý thôi, còn a cho rằng từ áo , ân mà vu vơ thì e chịu rồi. E cho rằng code cần phải chính xác trong đa số trường hợp rồi mới tính đến nhanh. E góp ý chứ ko tranh luận a ạ vì dữ liệu đâu chỉ như thế này, chẳng lẽ ko có người nào tên ân, cửa hàng may mặc nào chẳng có áo và vô vàn trường hợp khác

Hoang2013 · 20/11/17

Cũng chưa rõ tác giả bài đăng có trường/cột cần tìm thuộc dữ liệu loại gì?
Nữa giống tên người, vì có năm sinh
Nhưng nữa khác lại đề là tên hàng hóa

Mô fật, nếu đó là cột/trường họ tên thì mình có cách khác chắc chắn hơn để tìm.

mykoloda · 20/11/17

HieuCD đã viết:

Do thiếu dòng lệnh bỏ dấu trong sub
tmp = Up_TV_KhongDau(tmp)

Mã:

Private Sub Add_Data()
  Dim dArr As Variant, tmp As String, key As String, i As Long, j As Integer
  i = Sheets("Sheet1").Range("B65500").End(xlUp).Row
  dArr = Sheets("Sheet1").Range("B4:B" & i).Value
  ReDim Sarr(1 To UBound(dArr), 1 To 2)
  For i = 1 To UBound(dArr)
    tmp = UCase(dArr(i, 1))
    If tmp <> "" Then
      tmp = Up_TV_KhongDau(tmp)
      For j = 1 To Len(tmp)
        key = Mid(tmp, i, 1)
        If dic.Exists(key) Then Mid(tmp, i, 1) = dic.Item(key)
      Next
      Sarr(i, 1) = tmp
      Sarr(i, 2) = dArr(i, 1)
    End If
  Next i
End Sub

Rất nhanh bác cho hỏi muốn hiển thị thêm cột trong listbox để lấy dữ liệu column trong đó,Vậy phải lam sao bác ?

PacificPR · 20/11/17

Ì hí.Dữ liệu của em nhỏ ( khoảng 4 con số 9) nên chung thành với Filter2DArray thôi

HieuCD · 20/11/17

SA_DQ đã viết:
Mình cho là vầy:
Khi nhập vô TextBox từ 'Chá', VBE vẫn đi tìm các từ trong dòng có "cha" & là có tìm thấy;
Nhưng từ 'Cháo' mà ta nhập vô TextBox nó đã bị xóa dấu sắc đi rồi; Nó đi tìm từ "Chao"; Bạn nào thữ thêm từ 'Chao' trong cột dữ liệu xem sao?

Mình thử như thế này:
Nhập chữ 'Cháy' vô 1 ô trang tính & chép lên TextBox, thì nó tìm chữ 'chay' & cả chữ 'cháy'

Bài nầy yêu cầu tìm từ gần đúng không xét dấu tiếng Việt, ví dụ "ăn", "ân", "ạn" đều chuyển về "an" và tìm theo từ "an", nên từ gỏ vào Text box " "Chao", "Cháo" code xem là giống nhau

Hamedanger đã viết:
E góp ý thôi, còn a cho rằng từ áo , ân mà vu vơ thì e chịu rồi. E cho rằng code cần phải chính xác trong đa số trường hợp rồi mới tính đến nhanh. E góp ý chứ ko tranh luận a ạ vì dữ liệu đâu chỉ như thế này, chẳng lẽ ko có người nào tên ân, cửa hàng may mặc nào chẳng có áo và vô vàn trường hợp khác

Do đã bỏ dấu tiếng Việt nên khi chỉ gỏ vài ký tự của 1 từ, code sẽ tìm thấy những dòng không có liên quan gì đến mục đích tìm kiếm, nhưng khi số chữ nhiều thì code sẽ nhận dạng và loại bỏ những dòng không liên quan

HieuCD · 20/11/17

mykoloda đã viết:
Rất nhanh bác cho hỏi muốn hiển thị thêm cột trong listbox để lấy dữ liệu column trong đó,Vậy phải lam sao bác ?

Số cột trong Listbox lệ thuộc vào số cột của mảng Arr, hơn 2 cột phải viết lại code, gởi file dữ liệu giả định với các cột cùng yêu cầu sát thực tế viết mới hợp ý được

mykoloda · 20/11/17

HieuCD đã viết:
Số cột trong Listbox lệ thuộc vào số cột của mảng Arr, hơn 2 cột phải viết lại code, gởi file dữ liệu giả định với các cột cùng yêu cầu sát thực tế viết mới hợp ý được

Trong file mình có ghi tiêu đề nhờ bác giúp

HieuCD · 20/11/17

mykoloda đã viết:
Trong file mình có ghi tiêu đề nhờ bác giúp

Cần làm rỏ thêm:
_ Có loại bỏ dấu tiếng Việt Không
_ Tìm theo 2 cột, điều kiện là cả 2 cùng thỏa hay 1 trong 2
- Số ký tự trung bình 1 ô của từng cột tìm dữ liệu là bao nhiêu ký tự kể cả khoảng trống

mykoloda · 20/11/17

HieuCD đã viết:
Cần làm rỏ thêm:
_ Có loại bỏ dấu tiếng Việt Không
_ Tìm theo 2 cột, điều kiện là cả 2 cùng thỏa hay 1 trong 2
- Số ký tự trung bình 1 ô của từng cột tìm dữ liệu là bao nhiêu ký tự kể cả khoảng trống

_Sẽ là có nếu loại bỏ dấu sẽ nhanh hơn
_1 trong 2 thui bác à
_Trug bình tầm 15 ký tự

HieuCD · 20/11/17

mykoloda đã viết:
_Sẽ là có nếu loại bỏ dấu sẽ nhanh hơn
_1 trong 2 thui bác à
_Trug bình tầm 15 ký tự

Loại bỏ dấu code viết phức tạp hơn và chạy chậm hơn rất nhiều

mykoloda · 20/11/17

HieuCD đã viết:
Loại bỏ dấu code viết phức tạp hơn và chạy chậm hơn rất nhiều

Vậy dùng đấu cho chính xác cũng được bác ơi

HieuCD · 20/11/17

mykoloda đã viết:
_Sẽ là có nếu loại bỏ dấu sẽ nhanh hơn
_1 trong 2 thui bác à
_Trug bình tầm 15 ký tự

Bạn cho vài ví dụ cụ thể về điều kiện lọc ở 2 cột và kết quả

mykoloda · 20/11/17

HieuCD đã viết:
Bạn cho vài ví dụ cụ thể về điều kiện lọc ở 2 cột và kết quả

Ví dụ gõ b1 hoặc c1 từ textbox sẽ ra b1,c1,d1,e1,f1,g1 trog bảng listbox đó bác

HieuCD · 20/11/17

mykoloda đã viết:
Ví dụ gõ b1 hoặc c1 từ textbox sẽ ra b1,c1,d1,e1,f1,g1 trog bảng listbox đó bác

Vậy là khi gỏ vào Textbox, sẽ dò ở cả 2 cột, nếu phù hợp thì lấy, có khả năng muốn tìm ở cột 1 nhưng cột 2 phù hợp cũng lấy luôn? và ngược lại

mykoloda · 20/11/17

HieuCD đã viết:
Vậy là khi gỏ vào Textbox, sẽ dò ở cả 2 cột, nếu phù hợp thì lấy, có khả năng muốn tìm ở cột 1 nhưng cột 2 phù hợp cũng lấy luôn? và ngược lại

Vâng chính là nó bác à

HieuCD · 20/11/17

mykoloda đã viết:
Vâng chính là nó bác à

xem file

mykoloda · 20/11/17

HieuCD đã viết:
xem file

Cảm ơn bác nhiều.Bác cho hỏi Muốn hiển thị thêm 1 cột nữa trong listbox phải chỉnh sao bác.Em có thêm ColumnCount nhưng nó lại hiện các cột mà bác đã loại bỏ dấu

HieuCD · 20/11/17

mykoloda đã viết:
Cảm ơn bác nhiều.Bác cho hỏi Muốn hiển thị thêm 1 cột nữa trong listbox phải chỉnh sao bác.Em có thêm ColumnCount nhưng nó lại hiện các cột mà bác đã loại bỏ dấu

textbox1.list=darr là lệnh đưa dữ liệu vào, khai báo darr 7 cột và list 7 cột

mykoloda · 21/11/17

HieuCD đã viết:
textbox1.list=darr là lệnh đưa dữ liệu vào, khai báo darr 7 cột và list 7 cột

Bác có thể đưa code cần thay không ạ.Em làm nó hiển thị thêm cột nhưng không có dữ liệu cột mới thêm bác à

HieuCD · 21/11/17

mykoloda đã viết:
Bác có thể đưa code cần thay không ạ.Em làm nó hiển thị thêm cột nhưng không có dữ liệu cột mới thêm bác à

Dữ liệu chỉ có 6 cột, cột 7 bạn lấy ở đâu?

mykoloda · 21/11/17

HieuCD đã viết:
Dữ liệu chỉ có 6 cột, cột 7 bạn lấy ở đâu?

Em có thêm dữ liệu ở cột thứ 7 nhưng chỉ hiện khoảng trống không thấy dữ liệu đâu cả,Em có thay Redim darr(1 to k, 1 to 7) và listbox.columncount = 7

HieuCD · 21/11/17

mykoloda đã viết:
Em có thêm dữ liệu ở cột thứ 7 nhưng chỉ hiện khoảng trống không thấy dữ liệu đâu cả,Em có thay Redim darr(1 to k, 1 to 7) và listbox.columncount = 7

Vấn đề là phải có dữ liệu đưa vào cột 7 của dArr, file bạn gởi chỉ có 6 cột thôi

mykoloda · 21/11/17

HieuCD đã viết:
Vấn đề là phải có dữ liệu đưa vào cột 7 của dArr, file bạn gởi chỉ có 6 cột thôi

Đúng rùi nhưng em muốn hỏi để nhỡ sau này phát sinh thêm cột nữa.Thì không phải phiền tới bác ạ

HieuCD · 21/11/17

mykoloda đã viết:
Đúng rùi nhưng em muốn hỏi để nhỡ sau này phát sinh thêm cột nữa.Thì không phải phiền tới bác ạ

xem file

mykoloda · 21/11/17

HieuCD đã viết:
xem file

Cảm ơn bác nhiều...

Giúp code lọc dữ liệu siêu tốc khoảng 10.000 dòng (1 người xem)

Người dùng đang xem chủ đề này

Thành viên bị đình chỉ hoạt động

Chuyên gia GPE

Thành viên bị đình chỉ hoạt động

Huyền thoại GPE

Chuyên gia GPE

Thành viên bị đình chỉ hoạt động

File đính kèm

Biên Hòa, Đồng Nai

File đính kèm

Huyền thoại GPE

File đính kèm

Thành viên bị đình chỉ hoạt động

Thành viên bị đình chỉ hoạt động

Nghị Hách

Thành viên mới

Thành viên gắn bó

Nghị Hách

Thành viên gạo cội

Nghị Hách

Thành viên hoạt động

Thành viên chính thức

File đính kèm

Chuyên gia GPE

File đính kèm

Thành viên gắn bó

Chuyên gia GPE

File đính kèm

Thành viên chính thức

Chuyên gia GPE

/(hông là gì!

Thành viên chính thức

Thành viên gắn bó

Thành viên chính thức

Thành viên mới

Chuyên gia GPE

Chuyên gia GPE

Thành viên chính thức

File đính kèm

Chuyên gia GPE

Thành viên chính thức

Chuyên gia GPE

Thành viên chính thức

Chuyên gia GPE

Thành viên chính thức

Chuyên gia GPE

Thành viên chính thức

Chuyên gia GPE

File đính kèm

Thành viên chính thức

Chuyên gia GPE

Thành viên chính thức

Chuyên gia GPE

Thành viên chính thức

Chuyên gia GPE

Thành viên chính thức

Chuyên gia GPE

File đính kèm

Thành viên chính thức

Thời gian đếm ngược.