Giúp code lọc dữ liệu siêu tốc khoảng 10.000 dòng (3 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à!

Giúp code lọc dữ liệu siêu tốc khoảng 10.000 dòng (3 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ó

Đếm ngược thời gian