Nhờ các bạn cải thiện tốc độ search dữ liệu trên listbox! (1 người xem)

mickeybh · 25/11/13

Nhờ các bạn xem code và cải thiện tốc độ tìm kiếm trên listbox.
Dữ liệu ít thì hoạt động khá tốt nhưng dữ liệu gần 40 ngàn dòng thì nó gần như treo và văng ra ngoài luôn.
Code này mình sưu tầm trên GPE nhưng có thay đổi lại cho phù hợp với công việc.
https://app.box.com/s/2b2h8eodcc9ok2r5r3mb

Cảm ơn các bạn nhiều!

qtm1987 · 25/11/13

bạn thử thay bằng đoạn code này xem sao, kiểu mảng này thấy xử lý nhanh nè, bạn sửa lại cho phù hợp là ok.

PHP:

Private Sub SMaBenh_Change()
Dim sArray, Arr, Tmp, i As Long
With Sheets("ICD10")
    sArray = .Range(.[B2], .[B65536].End(xlUp)).Resize(, 2)
    ReDim Arr(1 To UBound(sArray, 1), 1 To 1)
    For i = 1 To UBound(sArray, 1)
        Arr(i, 1) = UCase(sArray(i, 1)) & "....." & sArray(i, 2)
    Next
    Tmp = Application.Transpose(Arr)
    Tmp = Filter(Tmp, UCase(Me.SMaBenh), 1)
    Me.List_ICD10.List() = Tmp
End With
End Sub

Let'GâuGâu · 25/11/13

mickeybh đã viết:
Nhờ các bạn xem code và cải thiện tốc độ tìm kiếm trên listbox.
Dữ liệu ít thì hoạt động khá tốt nhưng dữ liệu gần 40 ngàn dòng thì nó gần như treo và văng ra ngoài luôn.
Code này mình sưu tầm trên GPE nhưng có thay đổi lại cho phù hợp với công việc.
https://app.box.com/s/2b2h8eodcc9ok2r5r3mb

Cảm ơn các bạn nhiều!

nâng cấp máy đi bạn, tôi thấy nó chạy cũng được mà
----------------
tôi thử bằng FindAllMethod, bạn xem có khá hơn chút nào không

sealand · 25/11/13

Khi lập trình ta chú ý xây dựng các Module dùng chung khi cần ta gọi lại, Code sẽ gọn gàng khoa học hơn:
1/ Bạn chèn thêm 1 Sub vào trong phần Code của Form:

Mã:

Sub Set_ICD(ByVal Ch As String, ByVal Col As Integer)
Dim Tm, i, j, Kq()
Tm = Sheets("ICD10").Range("B2:C" & Cells(Rows.Count, 2).End(xlUp).Row)
For i = 1 To UBound(Tm, 1)
If UCase(Tm(i, Col)) Like "*" & UCase(Ch) & "*" Then
j = j + 1
ReDim Preserve Kq(1 To 2, 1 To j)
Kq(1, j) = Tm(i, 1)
Kq(2, j) = Tm(i, 2)
End If
Next
Me.List_ICD10.Clear
If j > 0 Then Me.List_ICD10.List() = WorksheetFunction.Transpose(Kq)
End Sub

2/ Sửa 2 Sub cho 2 Textbox_Change như sau:

Mã:

Private Sub SMaBenh_Change()
Set_ICD SMaBenh.Text, 1
End Sub
'------------------------------
Private Sub STenBenh_Change()
Set_ICD STenBenh.Text, 2
End Sub

phucbugis · 25/11/13

sealand đã viết:
Khi lập trình ta chú ý xây dựng các Module dùng chung khi cần ta gọi lại, Code sẽ gọn gàng khoa học hơn:
1/ Bạn chèn thêm 1 Sub vào trong phần Code của Form:

Mã:

Sub Set_ICD(ByVal Ch As String, ByVal Col As Integer) Dim Tm, i, j, Kq() Tm = Sheets("ICD10").Range("B2:C" & Cells(Rows.Count, 2).End(xlUp).Row) For i = 1 To UBound(Tm, 1) If UCase(Tm(i, Col)) Like "*" & UCase(Ch) & "*" Then j = j + 1 ReDim Preserve Kq(1 To 2, 1 To j) Kq(1, j) = Tm(i, 1) Kq(2, j) = Tm(i, 2) End If Next Me.List_ICD10.Clear If j > 0 Then Me.List_ICD10.List() = WorksheetFunction.Transpose(Kq) End Sub

2/ Sửa 2 Sub cho 2 Textbox_Change như sau:

Mã:

Private Sub SMaBenh_Change() Set_ICD SMaBenh.Text, 1 End Sub '------------------------------ Private Sub STenBenh_Change() Set_ICD STenBenh.Text, 2 End Sub

Mình đã test, chạy khá nhanh. |||||

Bạn Sealand ơi, cho mình hỏi.
Cũng với form đó nếu mình áp dụng cho Listview1 thì phải sửa code lại như thế nào cho đúng vậy?

Thanks! --=0

mickeybh · 25/11/13

Let'GâuGâu đã viết:
nâng cấp máy đi bạn, tôi thấy nó chạy cũng được mà
----------------
tôi thử bằng FindAllMethod, bạn xem có khá hơn chút nào không

Code của bạn có nhanh hơn 1 tí

. Nâng cấp máy thì chắc thôi (mình đang xài con E7400 2.8Gb, ram 4gb nên cũng chẳng biết cấu hình thế nào là đủ)
Code của bạn qtm1987 khi tìm nó ghép 2 cột lại với nhau nhìn không thích lắm

Code của bạn sealand đúng là nhanh hơn nhiều nhưng khó hiểu quá và khi đưa vào form chính thì chỉ tìm được các SMaBenh bắt đầu chữ A thôi, còn lại không tìm thấy

Cảm ơn tất cả các bạn!
Nhờ các bạn thêm 1 tí:
- Khi tìm xong dữ liệu thì mình doubleclick chuột vào thì nó ghi sang listbox bên cạnh, giờ mình muốn xóa những dữ liệu đã chọn ở listbox bên cạnh thì phải code như thế nào?
- Code DblClick() có cần chỉnh sửa gì không hay vẫn để vậy?
Mong các bạn giúp đỡ!

mickeybh · 25/11/13

mickeybh đã viết:
Code của bạn có nhanh hơn 1 tí . Nâng cấp máy thì chắc thôi (mình đang xài con E7400 2.8Gb, ram 4gb nên cũng chẳng biết cấu hình thế nào là đủ)
Code của bạn qtm1987 khi tìm nó ghép 2 cột lại với nhau nhìn không thích lắm
Code của bạn sealand đúng là nhanh hơn nhiều nhưng khó hiểu quá
Cảm ơn tất cả các bạn!

Nhờ các bạn thêm 1 tí:
- Khi tìm xong dữ liệu thì mình doubleclick chuột vào thì nó ghi sang listbox bên cạnh, giờ mình muốn xóa những dữ liệu đã chọn ở listbox bên cạnh thì phải code như thế nào?
- Code DblClick() có cần chỉnh sửa gì không hay vẫn để vậy?
Mong các bạn giúp đỡ!
Nhờ mod xóa dùm bài này dùm mình với.

vodoi2x · 25/11/13

mickeybh đã viết:
Nhờ các bạn thêm 1 tí:
- Khi tìm xong dữ liệu thì mình doubleclick chuột vào thì nó ghi sang listbox bên cạnh, giờ mình muốn xóa những dữ liệu đã chọn ở listbox bên cạnh thì phải code như thế nào?
- Code DblClick() có cần chỉnh sửa gì không hay vẫn để vậy?
Mong các bạn giúp đỡ!
Nhờ mod xóa dùm bài này dùm mình với.

XOÁ ở list nào
List_ChanDoan
hay
List_ICD10
????
Phải nói rõ, mới có phương án (?)

mickeybh · 25/11/13

Tìm bên listbox ICD10, kích đúp chuột thì nó nhảy sang list ChanDoan. Nhưng có thể do chọn nhầm thì cần phải xóa đi để chọn lại cái khác

.
Mình cần xóa list ChanDoan.

vodoi2x · 25/11/13

mickeybh đã viết:
Tìm bên listbox ICD10, kích đúp chuột thì nó nhảy sang list ChanDoan. Nhưng có thể do chọn nhầm thì cần phải xóa đi để chọn lại cái khác .
Mình cần xóa list ChanDoan.

Vậy thì dùng event Double click của List_ChanDoan để XOÁ

PHP:

Private Sub List_ChanDoan_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    With List_ChanDoan
        .RemoveItem (.ListIndex)
    End With
End Sub

sealand · 26/11/13

phucbugis đã viết:
Mình đã test, chạy khá nhanh.
Bạn Sealand ơi, cho mình hỏi.
Cũng với form đó nếu mình áp dụng cho Listview1 thì phải sửa code lại như thế nào cho đúng vậy?

Thanks!

Code cho Listview như sau:

Mã:

Sub Set_ICD(ByVal Ch As String, ByVal Col As Integer)
Dim Tm, i, j, It As ListItem
Tm = Sheets("ICD10").Range("B2:C" & Cells(Rows.Count, 2).End(xlUp).Row)
Me.ListView1.ListItems.Clear
For i = 1 To UBound(Tm, 1)
If UCase(Tm(i, Col)) Like "*" & UCase(Ch) & "*" Then
Set It = Me.ListView1.ListItems.Add(, , Tm(i, 1))
It.SubItems(1) = Tm(i, 2)
End If
Next
End Sub

sealand · 26/11/13

mickeybh đã viết:
Tìm bên listbox ICD10, kích đúp chuột thì nó nhảy sang list ChanDoan. Nhưng có thể do chọn nhầm thì cần phải xóa đi để chọn lại cái khác .
Mình cần xóa list ChanDoan.

Giống như bài trước mình đã tham gia về việc sử dụng các Module dùng chung. Việc ở đây như sau:

+Nếu DblClick vào Item của List_ICD10 sẽ:
-Mang dòng chọn sang List_ChanDoan
-Xoá dòng chọn trên List_ICD10

+Nếu DblClick vào Item của List_ChanDoan sẽ:
-Mang dòng chọn sang List_ICD10 (Nếu chỉ xoá thì thiếu mã bệnh)
-Xoá dòng chọn trên List_ChanDoan

Hai thao tác này cũng giống nhau, vậy ta lập 1 Module dùng chung như sau:

Mã:

Private Sub Swap_Item(Name1 As String, Name2 As String)
Dim i, j, Ctr1 As Control, Ctr2 As Control
Set Ctr1 = Me.Controls(Name1)
Set Ctr2 = Me.Controls(Name2)
For i = 0 To Ctr1.ListCount - 1
If Ctr1.Selected(i) = True Then
j = Ctr2.ListCount
Ctr2.AddItem Ctr1.Column(0), j
Ctr2.List(j, 1) = Ctr1.List(i, 1)
Ctr1.RemoveItem (i)
Exit Sub
End If
Next
End Sub

Và 2 sub DblClick sẽ như sau:

Mã:

Private Sub List_ChanDoan_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Swap_Item "List_ChanDoan", "List_ICD10"
End Sub
'------------------------------
Private Sub List_ICD10_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Swap_Item "List_ICD10", "List_ChanDoan"
End Sub

ở đây ta mới chuyển đi và chuyển về vào cuối List. Nếu muốn đúng vị trí thì phải thêm 1 cột ẩn để lưu thứ tự dòng gốc

Hoàng Trọng Nghĩa · 26/11/13

sealand đã viết:

Code cho Listview như sau:

Mã:

Sub Set_ICD(ByVal Ch As String, ByVal Col As Integer)
Dim Tm, i, j, It As ListItem
Tm = Sheets("ICD10").Range("B2:C" & Cells(Rows.Count, 2).End(xlUp).Row)
Me.ListView1.ListItems.Clear
For i = 1 To UBound(Tm, 1)
If UCase(Tm(i, Col)) Like "*" & UCase(Ch) & "*" Then
Set It = Me.ListView1.ListItems.Add(, , Tm(i, 1))
It.SubItems(1) = Tm(i, 2)
End If
Next
End Sub

Từ khi xài Excel 2010 và 2013 thì em mới thật sự ngán thằng ListView, mặc dù đã check vào ListView Controls 6.0 nhưng nó vẫn báo lỗi không cho UserForm chứa ListView của Excel 2003 hoạt động! Còn ngược lại, lưu ListView của Excel 2010-2013 thành file 2003 thì máy đó chạy tốt, nhưng ở máy có Excel 2003 nó cũng không cho chạy cái ListView này, chả hiểu sao cả!! Từ đó em chỉ sử dụng mỗi ListBox mà thôi!

mickeybh · 26/11/13

sealand đã viết:
Khi lập trình ta chú ý xây dựng các Module dùng chung khi cần ta gọi lại, Code sẽ gọn gàng khoa học hơn:
1/ Bạn chèn thêm 1 Sub vào trong phần Code của Form:

Mã:

Sub Set_ICD(ByVal Ch As String, ByVal Col As Integer) Dim Tm, i, j, Kq() Tm = Sheets("ICD10").Range("B2:C" & Cells(Rows.Count, 2).End(xlUp).Row) For i = 1 To UBound(Tm, 1) If UCase(Tm(i, Col)) Like "*" & UCase(Ch) & "*" Then j = j + 1 ReDim Preserve Kq(1 To 2, 1 To j) Kq(1, j) = Tm(i, 1) Kq(2, j) = Tm(i, 2) End If Next Me.List_ICD10.Clear If j > 0 Then Me.List_ICD10.List() = WorksheetFunction.Transpose(Kq) End Sub

2/ Sửa 2 Sub cho 2 Textbox_Change như sau:

Mã:

Private Sub SMaBenh_Change() Set_ICD SMaBenh.Text, 1 End Sub '------------------------------ Private Sub STenBenh_Change() Set_ICD STenBenh.Text, 2 End Sub

Gửi sealand và các bạn!
Code này có thể bị ảnh hưởng bởi nguyên nhân nào khác làm ảnh hưởng đến kết quả tìm kiếm cũng như nạp dữ liệu vào listbox không?
Cùng 1 code nếu tạo 1 file mới hay trong file ví dụ mình gửi lên thì code hoạt động rất tốt nhưng khi đưa vào form chính của mình đang làm thì nó "cũng hoạt động" nhưng hình như nó chỉ nạp dữ liệu vào listbox vài dòng đầu tiên của sheet ICD10 thôi. Dù mình xóa hết code trong form của mình để thử nhưng kết quả vẫn y như thế, chỉ tìm được vài dòng đầu của dữ liệu bên sheet ICD10.
Mong được giúp đỡ!

sealand · 26/11/13

Code này khó có ảnh hưởng bởi các thiết lập nào khác vì nó không dựa trên sự thiết lappj nào. Để an toàn bạn sửa câu sau

Tm = Sheets("ICD10").Range("B2:C" & Cells(Rows.Count, 2).End(xlUp).Row)

Thành:

Tm = Sheets("ICD10").Range("B2:C" & Sheets("ICD10").Cells(Rows.Count, 2).End(xlUp).Row)

mickeybh · 26/11/13

sealand đã viết:
Code này khó có ảnh hưởng bởi các thiết lập nào khác vì nó không dựa trên sự thiết lappj nào. Để an toàn bạn sửa câu sau

Tm = Sheets("ICD10").Range("B2:C" & Cells(Rows.Count, 2).End(xlUp).Row)

Thành:

Tm = Sheets("ICD10").Range("B2:C" & Sheets("ICD10").Cells(Rows.Count, 2).End(xlUp).Row)

Cảm ơn bạn sealand nhiều. Đúng là thêm sheets("ICD10") vào trước cells thì code hoạt động bình thường.
Làm phiền bạn nếu được có thể giải thích thêm vào đoạn code bên dưới và #12:

Mã:

Sub Set_ICD(ByVal Ch As String, ByVal Col As Integer)
Dim Tm, i, j, Kq()
Tm = Sheets("ICD10").Range("B2:C" & Cells(Rows.Count, 2).End(xlUp).Row)
For i = 1 To UBound(Tm, 1)
If UCase(Tm(i, Col)) Like "*" & UCase(Ch) & "*" Then
j = j + 1
ReDim Preserve Kq(1 To 2, 1 To j)
Kq(1, j) = Tm(i, 1)
Kq(2, j) = Tm(i, 2)
End If
Next
Me.List_ICD10.Clear
If j > 0 Then Me.List_ICD10.List() = WorksheetFunction.Transpose(Kq)
End Sub

Xem code bạn viết mà chẳng hiểu được, chỉ máy móc đem vào sử dụng chứ không thể tuỳ biến khi muốn chỉnh sửa/

sealand · 28/11/13

Mình viết vậy nhưng giải thích thật khó:
1/Quy trình:

+Từ lệnh gọi ta nhận được 2 tham số:

-Ch: Chuỗi mẫu ký tự cần lọc.
-Col: Số thứ tự cột cần so sánh

+Tạo 1 mảng nguồn gồm 2 cột
+Căn cứ số thứ tụ cột và chuỗi mẫu, so sánh với từng dòng trên mảng nguồn. Nếu thoả mãn thì thêm phần tử mới cho mảng Kq và gán dữ liệu từ mảng nguồn sang.
+Kết thúc ta được mảng Kq
+Xoa Listbox
+Load mảng Kq lên Listbox bằng List()

2/Code:

Mã:

Sub Set_ICD(ByVal Ch As String, ByVal Col As Integer)
Dim Tm, i, j, Kq()
Tm = Sheets("ICD10").Range("B2:C" & Cells(Rows.Count, 2).End(xlUp).Row) 'Tao 1 mang chua du lieu vung nguon
For i = 1 To UBound(Tm, 1) 'Kiem tra tu dau mang nguon
If UCase(Tm(i, Col)) Like "*" & UCase(Ch) & "*" Then 'Neu thoa man dieu kien loc, thi bo xung mang Kq noi dung dong mang nguon
j = j + 1
ReDim Preserve Kq(1 To 2, 1 To j) 'Khai them dong cho mang Kq
Kq(1, j) = Tm(i, 1) 'Gan DL
Kq(2, j) = Tm(i, 2) 'Gan DL
End If
Next
Me.List_ICD10.Clear 'Xoa Listbox
If j > 0 Then Me.List_ICD10.List() = WorksheetFunction.Transpose(Kq) 'Nap lai Listbox
End Sub

quoc nhat · 2/12/13

Nhân tiện topic này có đề cập đến tốc độ search trên Listbox cho em hỏi với
Trong File em có sử dụng Fuction của thầy Ndu nhưng với dữ liệu nhiều Load dữ liệu thấy rất chậm, mong được sự chỉ dẫn của thầy Ndu và các thầy cô để khắc phục
Em cảm ơn!

phanminhphuong · 3/12/13

quoc nhat đã viết:
Nhân tiện topic này có đề cập đến tốc độ search trên Listbox cho em hỏi với
Trong File em có sử dụng Fuction của thầy Ndu nhưng với dữ liệu nhiều Load dữ liệu thấy rất chậm, mong được sự chỉ dẫn của thầy Ndu và các thầy cô để khắc phục
Em cảm ơn!

Dữ liệu 37560 dòng không chậm mới là lạ.
Chưa tìm ra được giải pháp nào nhanh hơn nhưng sửa thử code của bạn 1 số chỗ

Mã:

Private Sub TextBox1_Change() '[COLOR=#0000cd]=> Nếu thực sự không cần gõ thêm 1 kí tự thì tìm ngay nên dùng _AfterUpdate[/COLOR]
  LoadDT
End Sub
'================================================
Sub LoadDT()
Dim Dk As String, Arr(), Tm
On Error GoTo Thoat
    Dk = UCase(Trim(Me.TextBox1)) & "*"
    Tm = Sheet1.Range("A2:[COLOR=#ff0000]C[/COLOR]" & Sheet1.[A65536].End(xlUp).Row) '<= Code bạn viết chỗ màu đỏ là [COLOR=#ff0000]cột AB[/COLOR] để làm gì???
    Arr = Filter2DArray(Tm, 3, [COLOR=#ff0000]Dk[/COLOR], False) '<= Đã có [COLOR=#ff0000]Dk[/COLOR] ở trên sao không đưa vào, bạn lại viết lại [COLOR=#0000cd]UCase(Trim(Me.TextBox1)) & "*"[/COLOR] là thừa
    If ListBox1.ListCount > 0 Then ListBox1.Clear
    ListBox1.List() = Arr: Exit Sub
Thoat:
    If ListBox1.ListCount > 0 Then ListBox1.Clear
End Sub
'================================================
Private Sub UserForm_Initialize()
Dim Lg(), Lg1(), Td, i
Lg = Array(15, 100, 250)
Lg1 = Array(20, 40, 250)
Td = "|"
  For i = 1 To 3
    Td = Td & Left(Sheet1.Cells(1, i) & Space(130), Lg1(i - 1)) & "|"
  Next
Label1.Caption = Td
With ListBox1
  .ColumnCount = UBound(Lg) + 1
  .ColumnWidths = Join(Lg, ";")
  [COLOR=#0000cd].List() = Sheet1.Range("A2:C" & Sheet1.[A65536].End(xlUp).Row).Value[/COLOR] 'Nạp Listbox bình thường, không cần chạy Sub LoadDT cho tốn nhiều công đoạn
End With
End Sub

quoc nhat · 3/12/13

phanminhphuong đã viết:

Dữ liệu 37560 dòng không chậm mới là lạ.
Chưa tìm ra được giải pháp nào nhanh hơn nhưng sửa thử code của bạn 1 số chỗ

Mã:

Private Sub TextBox1_Change() '[COLOR=#0000cd]=> Nếu thực sự không cần gõ thêm 1 kí tự thì tìm ngay nên dùng _AfterUpdate[/COLOR]
  LoadDT
End Sub
'================================================
Sub LoadDT()
Dim Dk As String, Arr(), Tm
On Error GoTo Thoat
    Dk = UCase(Trim(Me.TextBox1)) & "*"
    Tm = Sheet1.Range("A2:[COLOR=#ff0000]C[/COLOR]" & Sheet1.[A65536].End(xlUp).Row) '<= Code bạn viết chỗ màu đỏ là [COLOR=#ff0000]cột AB[/COLOR] để làm gì???
    Arr = Filter2DArray(Tm, 3, [COLOR=#ff0000]Dk[/COLOR], False) '<= Đã có [COLOR=#ff0000]Dk[/COLOR] ở trên sao không đưa vào, bạn lại viết lại [COLOR=#0000cd]UCase(Trim(Me.TextBox1)) & "*"[/COLOR] là thừa
    If ListBox1.ListCount > 0 Then ListBox1.Clear
    ListBox1.List() = Arr: Exit Sub
Thoat:
    If ListBox1.ListCount > 0 Then ListBox1.Clear
End Sub
'================================================
Private Sub UserForm_Initialize()
Dim Lg(), Lg1(), Td, i
Lg = Array(15, 100, 250)
Lg1 = Array(20, 40, 250)
Td = "|"
  For i = 1 To 3
    Td = Td & Left(Sheet1.Cells(1, i) & Space(130), Lg1(i - 1)) & "|"
  Next
Label1.Caption = Td
With ListBox1
  .ColumnCount = UBound(Lg) + 1
  .ColumnWidths = Join(Lg, ";")
  [COLOR=#0000cd].List() = Sheet1.Range("A2:C" & Sheet1.[A65536].End(xlUp).Row).Value[/COLOR] 'Nạp Listbox bình thường, không cần chạy Sub LoadDT cho tốn nhiều công đoạn
End With
End Sub

cẢM ƠN ANH
Vì là quy định của Bộ y tế nên không thể thêm bớt được nên cũng đành chịu thôi
dù sao cũng xin cảm ơn anh một lần nữa
PS: đây không phải code em viết mà là của một thành viên trên diển đàn GPE mình em lấy về tham khảo thấy hợp nên chỉnh sửa một tý thôi chứ em đâu có khả năng viết code như vậy đâu anh.
Tất cả là hờ diển đàn cả đấy chứ

vodoi2x · 3/12/13

quoc nhat đã viết:
Nhân tiện topic này có đề cập đến tốc độ search trên Listbox cho em hỏi với
Trong File em có sử dụng Fuction của thầy Ndu nhưng với dữ liệu nhiều Load dữ liệu thấy rất chậm, mong được sự chỉ dẫn của thầy Ndu và các thầy cô để khắc phục
Em cảm ơn!

Dữ liệu gần 40 000 dòng, thì nhiều thật

Bạn sao không tìm phiên bản hàm Filter array mới - phiên bản này đã bỏ Dictionary, Evaluate cải thiện tốc độ nhiều của bác Siwtom tại đây (???)

Xem file kèm đã sử dụng MyFilter2DArray của bác siwtom đã cải thiện tốc độ nhiều, trong file cũng sửa lại 1 số code khác cho tốc độ nhanh hơn.

vodoi2x · 3/12/13

vodoi2x đã viết:
Dữ liệu gần 40 000 dòng, thì nhiều thật

Bạn sao không tìm phiên bản hàm Filter array mới - phiên bản này đã bỏ Dictionary, Evaluate cải thiện tốc độ nhiều của bác Siwtom tại đây (???)

Xem file kèm đã sử dụng MyFilter2DArray của bác siwtom đã cải thiện tốc độ nhiều, trong file cũng sửa lại 1 số code khác cho tốc độ nhanh hơn.

Áp dụng phương án mới hoàn toàn

Tự xây dựng Hàm filter cho riêng trường hợp vấn đề của người hỏi (tránh dùng dao to mổ con muỗi), đã cho TỐC ĐỘ TĂNG VÙ VÙ

hiện giờ file kèm đã cho tốc độ tức thì khi ng dùng gõ ký tự

Hoàng Trọng Nghĩa · 3/12/13

vodoi2x đã viết:
Áp dụng phương án mới hoàn toàn

Tự xây dựng Hàm filter cho riêng trường hợp vấn đề của người hỏi (tránh dùng dao to mổ con muỗi), đã cho TỐC ĐỘ TĂNG VÙ VÙ

hiện giờ file kèm đã cho tốc độ tức thì khi ng dùng gõ ký tự

Không biết cái mảng này có đúng địa chỉ không nhỉ?

Mã:

TM = Sheet1.Range("A2:[COLOR=#ff0000][B]AB[/B][/COLOR]" & Sheet1.[A65536].End(3).Row)

Tôi lại nghĩ nó phải như thế này chứ?

Mã:

TM = Sheet1.Range("A2:[COLOR=#ff0000][B]C[/B][/COLOR]" & Sheet1.[A65536].End(3).Row)

vodoi2x · 3/12/13

Hoàng Trọng Nghĩa đã viết:
Không biết cái mảng này có đúng địa chỉ không nhỉ?

Mã:

TM = Sheet1.Range("A2:[COLOR=#ff0000][B]AB[/B][/COLOR]" & Sheet1.[A65536].End(3).Row)

Tôi lại nghĩ nó phải như thế này chứ?

Mã:

TM = Sheet1.Range("A2:[COLOR=#ff0000][B]C[/B][/COLOR]" & Sheet1.[A65536].End(3).Row)

uhm, đoạn đó tôi không để ý, để nguyên như Code gốc

Sửa lại thế cho chuẩn và nhanh hơn như file kèm

siwtom · 3/12/13

vodoi2x đã viết:
Áp dụng phương án mới hoàn toàn

Tự xây dựng Hàm filter cho riêng trường hợp vấn đề của người hỏi (tránh dùng dao to mổ con muỗi), đã cho TỐC ĐỘ TĂNG VÙ VÙ

hiện giờ file kèm đã cho tốc độ tức thì khi ng dùng gõ ký tự

Bạn nói mà tôi có cảm tưởng bạn phát biểu tiên đề vậy.

Dĩ nhiên nếu tôi cầm dao mổ trâu để mổ con muỗi thì không thể thao tác nhanh và nhịp nhàng bằng bạn cầm dao mổ muỗi được. Mà dao to thế thì chỉ đập muỗi được chứ làm sao mổ được. He he.

Theo tôi nên xây dựng một module mà trong đó có dao mổ muỗi, dao mổ chim sẻ, dao mổ gà, dao mổ trâu, dao mổ một gà, dao mổ nhiều gà trong một thao tác v...v Tùy trường hợp cụ thể mà dùng.

Cũng là làm việc bạn chủ chủ đề cần nhưng tìm trên nhiều cột thì có thể tham khảo hàm Function MyFind2DArray có trong chủ đề

http://www.giaiphapexcel.com/forum/...-trên-Listview-(Userform)&p=549073#post549073

Tôi cũng viết sub hỗ trợ tạo mảng "điều kiện tìm kiếm" tên là Sub PrepareArray. Hiện Sub PrepareArray đang nằm trong code của UserForm. Hãy copy sang module modFind2DArray. Cách dùng sub/function thì tham khảo code trong UserForm trong link ở trên.

quoc nhat · 3/12/13

vodoi2x đã viết:
uhm, đoạn đó tôi không để ý, để nguyên như Code gốc

Sửa lại thế cho chuẩn và nhanh hơn như file kèm

Chắc là do máy tính của em cấu hình yếu hay sao mà phải mất 3s mới tìm được anh ạ
Cảm ơn anh nhiều

quoc nhat · 3/12/13

cẢM ƠN MỌI NGƯỜI ĐÃ GIÚP ĐỠ EM. NHIỀU CODE QUÁ EM SẺ THAM KHẢO ĐỂ HỌC HỎI THÊM

Hoàng Trọng Nghĩa · 3/12/13

quoc nhat đã viết:
Chắc là do máy tính của em cấu hình yếu hay sao mà phải mất 3s mới tìm được anh ạ
Cảm ơn anh nhiều

Bạn thử với form tôi thực hiện xem có mất 3 giây không nhé!

Toàn bộ code chỉ thế này:

Mã:

Option Explicit
Private FltCol As Byte


Private Sub UserForm_Initialize()
    If Not IsArray(pub_ArrDanhMuc) Then
        pub_ArrDanhMuc = Sheet1.Range("A2:C" & Sheet1.[A65536].End(3).Row)
        pub_Ubd = UBound(pub_ArrDanhMuc)
    End If
    lstDanhMuc.List = pub_ArrDanhMuc
    lblSoMuc.Caption = Format(lstDanhMuc.ListCount, "#,##0")
    optTenBenh = True
End Sub


Private Sub optSTT_Click()
    If optSTT Then
        FltCol = 1
        tbxTuKhoa = ""
        tbxTuKhoa.SetFocus
    End If
End Sub


Private Sub optMaBenh_Click()
    If optMaBenh Then
        FltCol = 2
        tbxTuKhoa = ""
        tbxTuKhoa.SetFocus
    End If
End Sub


Private Sub optTenBenh_Click()
    If optTenBenh Then
        FltCol = 3
        tbxTuKhoa = ""
        tbxTuKhoa.SetFocus
    End If
End Sub

[COLOR=#ff0000][B]''Code chính:[/B][/COLOR]
Private Sub tbxTuKhoa_Change()
    Dim GetRows()
    Dim strType As String
    Dim n As Long, r As Long
    ''strType = "*" & UCase(tbxTuKhoa) & "*"  ''<-- Neu muon loc bat ky
    strType = UCase(tbxTuKhoa) & "*"
    ReDim GetRows(1 To pub_Ubd)
    For r = 1 To pub_Ubd
        If UCase(pub_ArrDanhMuc(r, FltCol)) Like strType Then
            n = n + 1
            GetRows(n) = r
        End If
    Next
    If n Then
        Dim ArrFilter(), c As Byte
        ReDim ArrFilter(1 To n, 1 To 3)
        For r = 1 To n
            For c = 1 To 3
                ArrFilter(r, c) = pub_ArrDanhMuc(GetRows(r), c)
            Next
        Next
        lstDanhMuc.List = ArrFilter
    Else
        lstDanhMuc.List = Array()
    End If
    lblSoMuc.Caption = Format(lstDanhMuc.ListCount, "#,##0")
End Sub

Bạn nhìn hình, LƯU Ý, có 2 mục THỦY ĐẬU bị trùng nhé!

vodoi2x · 4/12/13

siwtom đã viết:
Bạn nói mà tôi có cảm tưởng bạn phát biểu tiên đề vậy.

Dĩ nhiên nếu tôi cầm dao mổ trâu để mổ con muỗi thì không thể thao tác nhanh và nhịp nhàng bằng bạn cầm dao mổ muỗi được. Mà dao to thế thì chỉ đập muỗi được chứ làm sao mổ được. He he.

Theo tôi nên xây dựng một module mà trong đó có dao mổ muỗi, dao mổ chim sẻ, dao mổ gà, dao mổ trâu, dao mổ một gà, dao mổ nhiều gà trong một thao tác v...v Tùy trường hợp cụ thể mà dùng.
.....

hiihiii, Bác ah, thực ra tiên đề gì đâu ạ,
Đúng là tùy bài cụ thể mà hàm khác nhau, người mới hiểu VBA thì cứ nghe danh hàm hay hàm to tưởng là hay bê về đặt nguyên xi vào nó chậm, nên "viết kiểu tiên đề.." như là nhấn mạnh cho họ biết lần sau cách chọn "dao" phù hợp

quoc nhat đã viết:
Chắc là do máy tính của em cấu hình yếu hay sao mà phải mất 3s mới tìm được anh ạ
Cảm ơn anh nhiều

Thế thì máy tính bạn cấu hình yếu thật

----------------
Thực ra tìm trong gần 40.000 mà tìm dạng text thì lâu là chắc --- nếu tối ưu thì quan trọng là danh sách tìm kiếm cần ngắn gọn (đã được phân loại theo từ khóa -keywords), đã được sắp xếp A->Z, đã được chỉ số hóa (index) một cách hợp lý thì mới tìm nhanh được

Còn không thì đạt "tốc độ chấp nhận" được là tốt rùi

quoc nhat · 4/12/13

Hoàng Trọng Nghĩa đã viết:

Bạn thử với form tôi thực hiện xem có mất 3 giây không nhé!

Toàn bộ code chỉ thế này:

Mã:

Option Explicit
Private FltCol As Byte


Private Sub UserForm_Initialize()
    If Not IsArray(pub_ArrDanhMuc) Then
        pub_ArrDanhMuc = Sheet1.Range("A2:C" & Sheet1.[A65536].End(3).Row)
        pub_Ubd = UBound(pub_ArrDanhMuc)
    End If
    lstDanhMuc.List = pub_ArrDanhMuc
    lblSoMuc.Caption = Format(lstDanhMuc.ListCount, "#,##0")
    optTenBenh = True
End Sub


Private Sub optSTT_Click()
    If optSTT Then
        FltCol = 1
        tbxTuKhoa = ""
        tbxTuKhoa.SetFocus
    End If
End Sub


Private Sub optMaBenh_Click()
    If optMaBenh Then
        FltCol = 2
        tbxTuKhoa = ""
        tbxTuKhoa.SetFocus
    End If
End Sub


Private Sub optTenBenh_Click()
    If optTenBenh Then
        FltCol = 3
        tbxTuKhoa = ""
        tbxTuKhoa.SetFocus
    End If
End Sub

[COLOR=#ff0000][B]''Code chính:[/B][/COLOR]
Private Sub tbxTuKhoa_Change()
    Dim GetRows()
    Dim strType As String
    Dim n As Long, r As Long
    ''strType = "*" & UCase(tbxTuKhoa) & "*"  ''<-- Neu muon loc bat ky
    strType = UCase(tbxTuKhoa) & "*"
    ReDim GetRows(1 To pub_Ubd)
    For r = 1 To pub_Ubd
        If UCase(pub_ArrDanhMuc(r, FltCol)) Like strType Then
            n = n + 1
            GetRows(n) = r
        End If
    Next
    If n Then
        Dim ArrFilter(), c As Byte
        ReDim ArrFilter(1 To n, 1 To 3)
        For r = 1 To n
            For c = 1 To 3
                ArrFilter(r, c) = pub_ArrDanhMuc(GetRows(r), c)
            Next
        Next
        lstDanhMuc.List = ArrFilter
    Else
        lstDanhMuc.List = Array()
    End If
    lblSoMuc.Caption = Format(lstDanhMuc.ListCount, "#,##0")
End Sub

Bạn nhìn hình, LƯU Ý, có 2 mục THỦY ĐẬU bị trùng nhé!

trên cả tuyệt vời không biết nói gì hơn .cảm ơn anh nhiều lắm

vodoi2x · 4/12/13

quoc nhat đã viết:
trên cả tuyệt vời không biết nói gì hơn .cảm ơn anh nhiều lắm

Sử dụng index theo sắp xếp ABC của ký tự đầu --> tốc độ tăng gấp 5-8 lần (tùy thuộc vào tỷ lệ các ký tự đầu)

chú ý trong sheet

Bảng index sắp xếp lại theo ABC của từng trường nên tốc độ tăng lên đáng kể

(các ô chữ đỏ là ô chứa công thức khi cần bổ sung thì kéo lại,
Các mục chưa có tiêu đề, tạm thời đặt tiêu đề là Z cho bảng index ABC của [Tên bệnh]

các ô được tô màu vàng là ô đặt NAME định vị

Các phần tô màu nền xanh là đọc vào code)

(bài sử dụng form của HoangTrongNghia)

xem file gửi kèm

quoc nhat · 4/12/13

vodoi2x đã viết:
Sử dụng index theo sắp xếp ABC của ký tự đầu --> tốc độ tăng gấp 5-8 lần (tùy thuộc vào tỷ lệ các ký tự đầu)

chú ý trong sheet

Bảng index sắp xếp lại theo ABC của từng trường nên tốc độ tăng lên đáng kể

(các ô chữ đỏ là ô chứa công thức khi cần bổ sung thì kéo lại,
Các mục chưa có tiêu đề, tạm thời đặt tiêu đề là Z cho bảng index ABC của [Tên bệnh]

các ô được tô màu vàng là ô đặt NAME định vị

Các phần tô màu nền xanh là đọc vào code)

(bài sử dụng form của HoangTrongNghia)

xem file gửi kèm

Anh nhiệt tình quá
Xin trân trọng cảm ơn anh.

vodoi2x · 4/12/13

Phương án mới, sửa lại

quoc nhat đã viết:
Anh nhiệt tình quá
Xin trân trọng cảm ơn anh.

Quá thật ah, cái gì quá cũng không hay, không hiểu ý bạn là thế nào?
Đã thử chưa, xem phương án mới có tốc độ nhanh hơn nhiều không - còn phải chờ 3s????

Sửa lại phương án mới, để cho label báo số lượng mục tìm thấy chính xác hơn

(các bạn download cái mới ở file kèm)

mickeybh · 4/12/13

Cảm ơn các bạn tham gia và đóng góp nhiệt tình. Mình thử hết các code trên, cho đến hiện tại code của bạn Hoàng Trọng Nghĩa vẫn tìm kiếm nhanh nhất (theo ý kiến chủ quan của mình nha).

mickeybh · 5/12/13

Hoàng Trọng Nghĩa đã viết:

Bạn thử với form tôi thực hiện xem có mất 3 giây không nhé!

Toàn bộ code chỉ thế này:

Mã:

Option Explicit
Private FltCol As Byte


Private Sub UserForm_Initialize()
    If Not IsArray(pub_ArrDanhMuc) Then
        pub_ArrDanhMuc = Sheet1.Range("A2:C" & Sheet1.[A65536].End(3).Row)
        pub_Ubd = UBound(pub_ArrDanhMuc)
    End If
    lstDanhMuc.List = pub_ArrDanhMuc
    lblSoMuc.Caption = Format(lstDanhMuc.ListCount, "#,##0")
    optTenBenh = True
End Sub


Private Sub optSTT_Click()
    If optSTT Then
        FltCol = 1
        tbxTuKhoa = ""
        tbxTuKhoa.SetFocus
    End If
End Sub


Private Sub optMaBenh_Click()
    If optMaBenh Then
        FltCol = 2
        tbxTuKhoa = ""
        tbxTuKhoa.SetFocus
    End If
End Sub


Private Sub optTenBenh_Click()
    If optTenBenh Then
        FltCol = 3
        tbxTuKhoa = ""
        tbxTuKhoa.SetFocus
    End If
End Sub

[COLOR=#ff0000][B]''Code chính:[/B][/COLOR]
Private Sub tbxTuKhoa_Change()
    Dim GetRows()
    Dim strType As String
    Dim n As Long, r As Long
    ''strType = "*" & UCase(tbxTuKhoa) & "*"  ''<-- Neu muon loc bat ky
    strType = UCase(tbxTuKhoa) & "*"
    ReDim GetRows(1 To pub_Ubd)
    For r = 1 To pub_Ubd
        If UCase(pub_ArrDanhMuc(r, FltCol)) Like strType Then
            n = n + 1
            GetRows(n) = r
        End If
    Next
    If n Then
        Dim ArrFilter(), c As Byte
        ReDim ArrFilter(1 To n, 1 To 3)
        For r = 1 To n
            For c = 1 To 3
                ArrFilter(r, c) = pub_ArrDanhMuc(GetRows(r), c)
            Next
        Next
        lstDanhMuc.List = ArrFilter
    Else
        lstDanhMuc.List = Array()
    End If
    lblSoMuc.Caption = Format(lstDanhMuc.ListCount, "#,##0")
End Sub

Bạn nhìn hình, LƯU Ý, có 2 mục THỦY ĐẬU bị trùng nhé!

Gửi các bạn!

Bỏ cột STT hoặc không cần xét trong điều kiện tìm kiếm (để cho đẹp), nội dung tìm kiếm còn lại 2 cột, có thể không check vào mã bệnh hoặc tên bệnh mà chỉ cần gõ vào từ khóa chính nội dung có liên quan đến mã bệnh hoặc tên bệnh thì nó cho ra kết quả luôn không các bạn?

Hoàng Trọng Nghĩa · 5/12/13

mickeybh đã viết:
Gửi các bạn!

Bỏ cột STT hoặc không cần xét trong điều kiện tìm kiếm (để cho đẹp), nội dung tìm kiếm còn lại 2 cột, có thể không check vào mã bệnh hoặc tên bệnh mà chỉ cần gõ vào từ khóa chính nội dung có liên quan đến mã bệnh hoặc tên bệnh thì nó cho ra kết quả luôn không các bạn?

Bỏ optionSTT thì được:

Tức khi thiết kế Form bạn xóa cái Option đó đi; code trong form, bạn xoá thủ tục này đi:

Mã:

Private Sub optSTT_Click()
    If optSTT Then
        FltCol = 1
        tbxTuKhoa = ""
        tbxTuKhoa.SetFocus
    End If
End Sub

Còn việc lọc trên 2 cột thì vẫn có thể làm được, nhưng tôi khuyên là không nên! Thứ nhất nó phức tạp, thứ 2 nó sẽ rất lộn xộn sau khi lọc, đặc biệt thời gian lọc sẽ ít nhất là gấp đôi. Chỉ cần 1 thao tác là CLICK chọn cột sẽ nhanh hơn lọc cả 2 cột một lúc đấy!

Nhờ các bạn cải thiện tốc độ search dữ liệu trên listbox! (1 người xem)

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

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

Thành viên thường trực

Thành viên mới

File đính kèm

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

Thành viên tích cực

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

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

Nothing & Nothing

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

Nothing & Nothing

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

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

Chuyên gia GPE

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

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

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

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

Thành viên tiêu biểu

File đính kèm

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

Thành viên tiêu biểu

Nothing & Nothing

File đính kèm

Nothing & Nothing

File đính kèm

Chuyên gia GPE

Nothing & Nothing

File đính kèm

Thành viên gắn bó

Thành viên tiêu biểu

Thành viên tiêu biểu

Chuyên gia GPE

File đính kèm

Nothing & Nothing

Thành viên tiêu biểu

Nothing & Nothing

Thành viên tiêu biểu

Nothing & Nothing

File đính kèm

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

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

Chuyên gia GPE

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