[Help]Macro textbox và Listbox quá nặng

[ultimatum86]

Chào các anh/chị

Hiện tại mình có 1 file sử dụng textbox và listbox để gợi ý dữ liệu, nhưng do bên dữ liệu nhiều quá nên nó chạy rất chậm,

Anh/chị xem giúp với, có cách nào làm cho nó chạy hơn không? thay đổi code lại cũng được.

 

[sealand]

Code của bạn nặng vì Hàm TV là chính, bạn sửa lại như sau sẽ nhanh hơn:

Option Explicit
  Const CharCode = "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)"
  Const ResText = "aaaaaaaaaaaaaaaaadeeeeeeeeeeeiiiiiooooooooooooooooouuuuuuuuuuuyyyyy"

Function TV(ByVal Text As String) As String
  Dim Uni(), i As Long, tmp As String
  On Error Resume Next
  tmp = Text
  Uni = Split(CharCode, ",")
  For i = 0 To UBound(Uni)
    tmp = Replace(tmp, Uni(i), UCase(Mid(ResText, i + 1, 1)))
  Next
  TV = tmp
End Function

Code Loc() như sau sẽ lọc trên mảng và nạp 1 lần bằng phương thức List() cũng cải thiện về tốc độ:

Sub Loc()
Dim Tm, Tm1(), i, j
Tm = Sheet4.Range("A4:A" & Sheet4.[A65536].End(3).Row)
For i = 1 To UBound(Tm, 1)
If Tm(i, 1) <> "" Then
      If TV(Tm(i, 1)) Like TV("*" & ActiveSheet.TextBox1.Value & "*") Then
j = j + 1
ReDim Preserve Tm1(1 To j)
Tm1(j) = Tm(i, 1)
End If
End If
Next
If Sheet4.ListBox2.ListCount > 0 Then Sheet4.ListBox2.Clear
Sheet4.ListBox2.List() = Tm1
End Sub

 

[ultimatum86]

Code của bạn nặng vì Hàm TV là chính, bạn sửa lại như sau sẽ nhanh hơn:

Option Explicit
  Const CharCode = "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)"
  Const ResText = "aaaaaaaaaaaaaaaaadeeeeeeeeeeeiiiiiooooooooooooooooouuuuuuuuuuuyyyyy"

Function TV(ByVal Text As String) As String
  Dim Uni(), i As Long, tmp As String
  On Error Resume Next
  tmp = Text
  Uni = Split(CharCode, ",")
  For i = 0 To UBound(Uni)
    tmp = Replace(tmp, Uni(i), UCase(Mid(ResText, i + 1, 1)))
  Next
  TV = tmp
End Function

Code Loc() như sau sẽ lọc trên mảng và nạp 1 lần bằng phương thức List() cũng cải thiện về tốc độ:

Sub Loc()
Dim Tm, Tm1(), i, j
Tm = Sheet4.Range("A4:A" & Sheet4.[A65536].End(3).Row)
For i = 1 To UBound(Tm, 1)
If Tm(i, 1) <> "" Then
      If TV(Tm(i, 1)) Like TV("*" & ActiveSheet.TextBox1.Value & "*") Then
j = j + 1
ReDim Preserve Tm1(1 To j)
Tm1(j) = Tm(i, 1)
End If
End If
Next
If Sheet4.ListBox2.ListCount > 0 Then Sheet4.ListBox2.Clear
Sheet4.ListBox2.List() = Tm1
End Sub

dạ đúng là có chạy nhanh hơn rồi ah, nhưng cho e hỏi muốn chạy hơn có được không ạ,
và hiện tại trong textbox nếu mình đánh sai mã thì nó sẽ báo lỗi ngay, Mong Anh khắc phục giúp em.

 

[sealand]

Mình chả thấy cái Textbox của bạn ở đâu cả nên đoán thuốc thôi:

1/ Vùng DS tạo List là vùng mã, vậy nên chả cần Tiếng Việt làm chi. Bạn sửa như sau sẽ rất nhanh. Thay dòng:

If TV(Tm(i, 1)) Like TV("*" & ActiveSheet.TextBox1.Value & "*") Then

bằng dòng:

If Tm(i, 1) Like "*" & ActiveSheet.TextBox1.Value & "*" Then

2/Code Loc() nên sửa lại như sau:

Sub Loc() Dim Tm, Tm1(), i, j
If Sheet4.ListBox2.ListCount > 0 Then Sheet4.ListBox2.Clear
 Tm = Sheet4.Range("A4:A" & Sheet4.[A65536].End(3).Row)
 For i = 1 To UBound(Tm, 1)
 If Tm(i, 1) <> "" Then
If Tm(i, 1) Like "*" & ActiveSheet.TextBox1.Value & "*" Then
 j = j + 1
 ReDim Preserve Tm1(1 To j)
 Tm1(j) = Tm(i, 1)
 End If
 End If 
Next
 if j>0 then Sheet4.ListBox2.List() = Tm1 
End Sub

 

[ultimatum86]

Mình chả thấy cái Textbox của bạn ở đâu cả nên đoán thuốc thôi:

1/ Vùng DS tạo List là vùng mã, vậy nên chả cần Tiếng Việt làm chi. Bạn sửa như sau sẽ rất nhanh. Thay dòng:

If TV(Tm(i, 1)) Like TV("*" & ActiveSheet.TextBox1.Value & "*") Then

bằng dòng:

If Tm(i, 1) Like "*" & ActiveSheet.TextBox1.Value & "*" Then

2/Code Loc() nên sửa lại như sau:

Sub Loc() Dim Tm, Tm1(), i, j
If Sheet4.ListBox2.ListCount > 0 Then Sheet4.ListBox2.Clear
 Tm = Sheet4.Range("A4:A" & Sheet4.[A65536].End(3).Row)
 For i = 1 To UBound(Tm, 1)
 If Tm(i, 1) <> "" Then
If Tm(i, 1) Like "*" & ActiveSheet.TextBox1.Value & "*" Then
 j = j + 1
 ReDim Preserve Tm1(1 To j)
 Tm1(j) = Tm(i, 1)
 End If
 End If 
Next
 if j>0 then Sheet4.ListBox2.List() = Tm1 
End Sub

Đúng là nhanh hơn rất nhiều, thanks anh,

Nhưng mà còn 1 lỗi là khi em chọn các dòng ( chọn theo Row) thì nó sẽ báo lỗi ngay chưa copy gì cả, vì form của em cần phải copy Row và insert Row. Anh xem giúp em là bị lỗi gì nha.