Em cần giúp đỡ sửa lỗi Code VBA chạy chậm

[bap226]

Em chào Anh Chị.
Nhờ Anh Chị giúp em giải đáp vấn đề sau ạ.
- Em có code VBA dùng để ẩn các dòng theo điều kiện (ở file đính kèm), Nhưng code chỉ chạy nhanh ở mức dưới 300 dòng dữ liệu, Còn lên tới hơn 1000 dòng thì chạy rất chậm
(Em cần ẩn các dòng theo điều kiện vì khi lọc theo mặc định của Excel thì khi chạy VBA không còn đúng, Nhờ Anh Chị giải đáp giúp)
Nhờ Anh Chị giúp viết code VBA mới hoặc chỉnh sửa code trong file đính kèm để Ẩn dòng nhanh hơn.
Em cảm ơn.

 

[Ba mười ba]

Em chào Anh Chị.
Nhờ Anh Chị giúp em giải đáp vấn đề sau ạ.
- Em có code VBA dùng để ẩn các dòng theo điều kiện (ở file đính kèm), Nhưng code chỉ chạy nhanh ở mức dưới 300 dòng dữ liệu, Còn lên tới hơn 1000 dòng thì chạy rất chậm
(Em cần ẩn các dòng theo điều kiện vì khi lọc theo mặc định của Excel thì khi chạy VBA không còn đúng, Nhờ Anh Chị giải đáp giúp)
Nhờ Anh Chị giúp viết code VBA mới hoặc chỉnh sửa code trong file đính kèm để Ẩn dòng nhanh hơn.
Em cảm ơn.

Bạn thử thay thế sub cũa của bạn thành sub này xem, có nhanh hơn chút nào không?

Private Sub CbOK_Click()
   Application.ScreenUpdating = False
   Dim Dic As Object, i As Long, Rs As Long, k As Long, Ar()
   Dim Tx As Variant, Rn As Range, Ce As Range, Rn2(), n As Long
   Dim r As Range, LastRow As Long
   With Sheets("DHDS")
      LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row  '  đây là dòng cuối trong cột D , bạn có thể thay đổi hoặc nhập LastRow = 100 hoặc 1000 hoặc 10000 tùy bạn
      If LastRow < 4 Then Exit Sub
      Set Rn = .Range("D3:D" & LastRow)
      Rn.EntireRow.Hidden = True
   End With
   Set Dic = CreateObject("Scripting.dictionary")
   Ar = Array(CkHC, CkHCM, CkSCM1, CkSCM2, CkSoup, CkTSL, CkXMM)
   For i = 0 To 6
       If Ar(i) = True Then
           k = k + 1
           Tx = Ar(i).Caption
           Dic.Item(Tx) = k
       End If
   Next i
   If Dic.Count = 0 Then Exit Sub

   For Each Ce In Rn
       If Ce.Value Like "*,*" Then
           Rn2 = Array(Split(Ce.Value, ","))
           n = 0
           For i = 0 To UBound(Rn2(0))
               If Dic.Exists(Rn2(0)(i)) Then
                   n = 1
                   Exit For
               End If
           Next i
           If n <> 0 Then
              If r Is Nothing Then
                  Set r = Ce
              Else
                  Set r = Union(r, Ce)
              End If
           End If
           'If Not r Is Nothing Then r.EntireRow.Hidden = False' <-- bỏ dòng này
       Else
           If Dic.Exists(Ce.Value) Then
              If r Is Nothing Then
                  Set r = Ce
              Else
                  Set r = Union(r, Ce)
              End If
           End If
       End If
   Next Ce
   If Not r Is Nothing Then r.EntireRow.Hidden = False
   Application.ScreenUpdating = True
End Sub

 

[bap226]

Bạn thử thay thế sub cũa của bạn thành sub này xem, có nhanh hơn chút nào không?

Private Sub CbOK_Click()
   Application.ScreenUpdating = False
   Dim Dic As Object, i As Long, Rs As Long, k As Long, Ar()
   Dim Tx As Variant, Rn As Range, Ce As Range, Rn2(), n As Long
   Dim r As Range, LastRow As Long
   With Sheets("DHDS")
      LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row  '  đây là dòng cuối trong cột D , bạn có thể thay đổi hoặc nhập LastRow = 100 hoặc 1000 hoặc 10000 tùy bạn
      If LastRow < 4 Then Exit Sub
      Set Rn = .Range("D3:D" & LastRow)
      Rn.EntireRow.Hidden = True
   End With
   Set Dic = CreateObject("Scripting.dictionary")
   Ar = Array(CkHC, CkHCM, CkSCM1, CkSCM2, CkSoup, CkTSL, CkXMM)
   For i = 0 To 6
       If Ar(i) = True Then
           k = k + 1
           Tx = Ar(i).Caption
           Dic.Item(Tx) = k
       End If
   Next i
   If Dic.Count = 0 Then Exit Sub

   For Each Ce In Rn
       If Ce.Value Like "*,*" Then
           Rn2 = Array(Split(Ce.Value, ","))
           n = 0
           For i = 0 To UBound(Rn2(0))
               If Dic.Exists(Rn2(0)(i)) Then
                   n = 1
                   Exit For
               End If
           Next i
           If n <> 0 Then
              If r Is Nothing Then
                  Set r = Ce
              Else
                  Set r = Union(r, Ce)
              End If
           End If
           If Not r Is Nothing Then r.EntireRow.Hidden = False
       Else
           If Dic.Exists(Ce.Value) Then
              If r Is Nothing Then
                  Set r = Ce
              Else
                  Set r = Union(r, Ce)
              End If
           End If
       End If
   Next Ce
   If Not r Is Nothing Then r.EntireRow.Hidden = False
   Application.ScreenUpdating = True
End Sub

Cảm ơn đoạn Code của bạn rất nhiều
Thơi gian chạy vẫn còn khá chậm bạn à.

 

[Ba mười ba]

Cảm ơn đoạn Code của bạn rất nhiều
Thơi gian chạy vẫn còn khá chậm bạn à.

đâu file thực tế của bạn đâu

 

[befaint]

For Each Ce In Rn
If Ce.Value Like "*,*" Then
'...
If Not r Is Nothing Then r.EntireRow.Hidden = False

Mình thử làm như này xem:

Chép Rn vào mảng rồi xử lý.
Thay Like bằng Instr().
Bỏ ẩn toàn bộ, tìm dòng thỏa điều kiện ẩn và gom lại, sau đó mới ẩn 1 lần.

 

[Ba mười ba]

Mình thử làm như này xem:

Chép Rn vào mảng rồi xử lý.
Thay Like bằng Instr().

Ồ cảm ơn bạn đoạn đó là của người trước, không phải của 'mình' bạn ah
Nhưng mình không nghĩ là đoạn code sau là ẩn một lần chứ không giống đoạn code cũ là xét từng dòng dòng nào phù hợp thì ẩn

 

[befaint]

Nhưng mình không nghĩ là đoạn code sau là ẩn một lần chứ không giống đoạn code cũ là xét từng dòng dòng nào phù hợp thì ẩn

Mình thấy trong vòng lặp đó.

 

[Ba mười ba]

Mình thấy trong vòng lặp đó.

View attachment 247061

ừ đúng, vậy xóa cái dòng đó

 

[bap226]

ừ đúng, vậy xóa cái dòng đó
View attachment 247065

Mình cảm ơn #Ba mười ba và #befaint rất nhiều
Mình đã thử theo và thành công rồi nha, Chạy nhanh bất ngờ.