Code VBA Xóa dòng theo điều kiện dùng AutoFilter

10 Responses

1. hands says:

   08/12/2023 at 6:07 pm

   Code này chỉ xoá dòng, chưa có xoá cột.

   Sub XoaDong()
   Dim arr(), i, j, k, kq()
   arr = Sheet1..CurrentRegion.Value
   ReDim kq(1 To UBound(arr), 1 To UBound(arr, 2))
   For i = 1 To UBound(arr)
   If Not arr(i, 6) Like "PW" & "*" Then
   k = k + 1
   For j = 1 To UBound(arr, 2)
   kq(k, j) = arr(i, j)
   Next
   End If
   Next
   Sheet1..Resize(i – 1, j – 1) = kq
   End Sub

   Bạn thử đoạn code này xem có cải thiện hơn không:

   Sub XoaDong()
       Dim x As Long, y As Long
       With Sheets("sheet1")
           ' Xac dinh dong cuoi cung
           x = .[B65000].End(3).Row
   
   For y = x To 9 Step -1
               If UCase(.Cells(y, 6)) Like "PW*" Then .Cells(y, 6).EntireRow.Delete
           Next
   
   End With
   End Sub

   Anh Hải truyền báthực phẩm chức năng Current Regiontrong trường hợp này có vẻ hơi NGUY HIỂM. –=0

   Ai biết đâu. Cứ thấy sao mần vậy thôi. Khi nào trật thì chủ thớt ráng chịu. Mình không có chịu à nghen.

   Reply
2. hands says:

   08/12/2023 at 6:07 pm

   Ai biết đâu. Cứ thấy sao mần vậy thôi. Khi nào trật thì chủ thớt ráng chịu. Mình không có chịu à nghen.

   Sau khi test xong em có kết quả như sau:

   – Code của anh Cá ngừ F1: Code này chạy rất lâu, theo em hiểu thì code này chưa chắc đã nhanh hơn cái autofilter, vì của anh nó phải duyệt từng dòng, dòng nào thỏa thì xóa, dữ liệu 4000 dòng như thế thì quá lâu.
   – Code của anh quanghai1969: Hiện tại em vẫn chưa chạy được, Chạy lên nó quay vòng khoảng 5s, sau đó xong, tưởng xong thật mừng quá trời nhưng nhìn lại nó ko thay đổi gì cả. 🙁
   Nhờ các anh xem lại giúp nha.

   Sub XoaDong()
   Dim arr(), i, j, k, kq()
   With Sheet1
   arr = .Range(.[B9], .[B65000].End(xlUp)).Resize(, 10).Value2
   End With
   ReDim kq(1 To UBound(arr), 1 To UBound(arr, 2))
   For i = 1 To UBound(arr)
      If Not arr(i, 5) Like "PW" & "*" Then
         k = k + 1
         For j = 1 To UBound(arr, 2)
            kq(k, j) = arr(i, j)
         Next
      End If
   Next
   Sheet1.[A15].Resize(i - 1, j - 1) = kq
   End Sub

   Bạn thử vậy xem được ko

   Reply
3. hands says:

   08/12/2023 at 6:07 pm

   Sub XoaDong()
   Dim arr(), i, j, k, kq()
   With Sheet1
   arr = .Range(.[B9], .[B65000].End(xlUp)).Resize(, 10).Value2
   End With
   ReDim kq(1 To UBound(arr), 1 To UBound(arr, 2))
   For i = 1 To UBound(arr)
      If Not arr(i, 5) Like "PW" & "*" Then
         k = k + 1
         For j = 1 To UBound(arr, 2)
            kq(k, j) = arr(i, j)
         Next
      End If
   Next
   Sheet1.[A15].Resize(i - 1, j - 1) = kq
   End Sub

   Bạn thử vậy xem được ko

   Code chạy rồi đó anh, rất nhanh, nhưng không đúng ý em.
   Em thấy code này giống như copy nhưng loại trừ những dòng có PW*, sau đó Paste lại đúng không anh.>>> Như thế sẽ bể form hết.
   Em chỉ muốn thực hiện Delete các dòng có chữ PW* thôi. ( Giống như thực hiện = tay thì khi xóa nó tự rút dòng lên, Form vẫn như cũ)

   Sub XoaDong()
   Dim arr(), i, j, k, kq()
   With Sheet1
   arr = .Range(.[B9], .[B65000].End(xlUp)).Resize(, 10).Value2
   End With
   ReDim kq(1 To UBound(arr), 1 To UBound(arr, 2))
   For i = 1 To UBound(arr)
      If Not arr(i, 5) Like "PW" & "*" Then
         k = k + 1
         For j = 1 To UBound(arr, 2)
            kq(k, j) = arr(i, j)
         Next
      End If
   Next
   Sheet1.[B9:K5000].ClearContents
   Sheet1.[B9].Resize(i - 1, j - 1) = kq
   End Sub

   Bạn thử thế này xem có được ko . Đại ca Quang Hải lên rồi đó, để anh xử lý tiếp bạn nhá

   Reply
4. hands says:

   08/12/2023 at 6:07 pm

   Anh xem có cách nào không nha.

   Rất xin lỗi, bữa giờ em đi công tác chưa test được, ý tưởng này rất hay đó anh, nhưng nếu nó copy luôn cả Format rồi sao đó paste lại có luôn format đó thì rất tuyệt.

   Anh xem có cách nào không nha.

   Bạn thử cách này xem. Tuy không nhanh bằng cách dùng mảng của quanghai nhưng theo đúng ý của bạn là như làm thủ công và có thể nhanh hơn cách dùng vòng lặp.

   Sub xxx()
       Application.ScreenUpdating = False:
       With Range([f10], [f65000].End(3))
           .Replace "PW*", "", 2
           .SpecialCells(4).EntireRow.Delete
       End With
   End Sub

   Reply
5. hands says:

   08/12/2023 at 6:09 pm

   Bạn thử cách này xem. Tuy không nhanh bằng cách dùng mảng của quanghai nhưng theo đúng ý của bạn là như làm thủ công và có thể nhanh hơn cách dùng vòng lặp.

   Sub xxx()
       Application.ScreenUpdating = False:
       With Range([f10], [f65000].End(3))
           .Replace "PW*", "", 2
           .SpecialCells(4).EntireRow.Delete
       End With
   End Sub

   Vẫn quá lâu anh ơi, nhưng sao e thấy những dòng nào trống cột F thì nó cũng xóa luôn ah.
   Em thấy code của anh quanghai rất hay,,chạy quá nhanh, nhưng vì ko rành mảng nên bó tay không biết làm thế nào để nó copy luôn format.
   Trên ý tưởng của anh quanghai, e đang tìm cách viết theo Range trước không biết có được không nữa.

   Với file đính kèm của bài 17 thì thế này là được.

   Sub Xoa()
   Dim arr(), i, rng As Range
   arr = .CurrentRegion.Value
   Set rng = Cells(65536, 1)
   For i = UBound(arr) To 1 Step -1
   If arr(i, 6) Like "PW" & "*" Then
   Set rng = Union(rng, Cells(i + 7, 1))
   End If
   Next
   rng.EntireRow.Delete
   End Sub

   Reply
6. hands says:

   08/12/2023 at 6:09 pm

   Với file đính kèm của bài 17 thì thế này là được.

   Sub Xoa()
   Dim arr(), i, rng As Range
   arr = .CurrentRegion.Value
   Set rng = Cells(65536, 1)
   For i = UBound(arr) To 1 Step -1
   If arr(i, 6) Like "PW" & "*" Then
   Set rng = Union(rng, Cells(i + 7, 1))
   End If
   Next
   rng.EntireRow.Delete
   End Sub

   Cảm ơn anh Hải nhiều, nhưng code này chạy trên file #17 rất nhanh vì chỉ có 3 hạng mục (STT) với hơn 100 dòng, em nhân số lượng dòng lên khoảng 3k (khoang STT 80) mà 25p rồi chưa xong anh ơi.

   Em thấy delete có vẽ không ổn đâu anh Hải, chắc phải dùng phương pháp copy rồi paste lại như của anh lúc trước mới nhanh được.

   Bạn dùng cái này thử xem

   Sub Xoa()
   Dim eR As Long, k As Long
   Dim Cls As Range
   Application.Calculation = xlCalculationManual
   Application.ScreenUpdating = False
   eR = Range("A65536").End(3).Row
   For Each Cls In Range("F10", Cells(eR, 6))
       If Cls Like "PW*" Then
           k = k + 1
           Cls.Offset(, 17) = ""
       Else
           Cls.Offset(, 17) = 1
       End If
   Next
   If k Then
       Range("W10", Cells(eR, 23)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
   End If
       Range("W10", Cells(eR, 23)).ClearContents
   
   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
   End Sub

   Reply
7. hands says:

   08/12/2023 at 6:10 pm

   Dạ cảm ơn anh dhn46, nhưng vẫn chậm lắm anh ơi,

   Em xin bổ sung file lại 2k dòng, có thể do file kia em gửi ít dòng quá nên các anh khó test. vì file của em không cố định, lúc thì khoảng hơn 100 dòng lúc thì tới 5K dòng.

   Giải nén file đính kèm. Chạy file để đăng ký VBA. Copy code này vào file cần xoá dòng và chạy thử.

   Public Sub Main()
   Dim arr()
   arr = Range("F10", .End(3)).Value
   With CreateObject("VBAVBA.vbsub")
   Set .ExcelApp = Application
   .DeleteRow arr
   End With
   End Sub

   Reply
8. hands says:

   08/12/2023 at 6:11 pm

   Giải nén file đính kèm. Chạy file để đăng ký VBA. Copy code này vào file cần xoá dòng và chạy thử.

   Public Sub Main()
   Dim arr()
   arr = Range("F10", .End(3)).Value
   With CreateObject("VBAVBA.vbsub")
   Set .ExcelApp = Application
   .DeleteRow arr
   End With
   End Sub

   Đã chạy rồi anh Hải ơi, chạy nó giải nén file VBA.dll vào systems32. Hay là do em dùng windows 64bit nên không chạy được.-+*/

   Tìm xem trong trong C:WindowsSysWOW64 có file VBAVBA.dll chưa. Nếu chưa có thì copy thủ công vào. Sau đó thử chạy file này. Nhớ là phải Run as…

   Reply
9. hands says:

   08/12/2023 at 6:11 pm

   Như đã nói

   …….. bạn hãy quay lại chính bài #1 của bạn đó, đặt vấn đề lại là bạn cần gì (?) , hãy nghĩ khác xoá đi,

   Từ code bài 1 thấy rằng mục đích chính của bạn là tạo file mới với dữ liệu lọc là không chứa các dòng mà tài cột F có giá trị PW*,

   Nên hình thành code sau (bổ sung, nâng cấp code #1 của bạn thôi) – đảm bảo tốc độ nhanh chấp nhận được, kết quả có đầy đủ định dạng format gốc

   Sub copyPppp()
       Dim t
       t = Timer
   
   Const sDK = "<>PW*"
       Dim Cll As Range
       Dim lR As Long
       Dim wbN As Workbook
       Dim rG As Range
       Dim Rg2 As Range
       Dim rgG As Range
   
   With Application
           .ScreenUpdating = False: .DisplayAlerts = False:  .EnableEvents = False
           .Calculation = xlCalculationAutomatic
       End With
   
   With ActiveSheet       
           .AutoFilterMode = False
            lR = .Cells(65000, 3).End(xlUp).Row
           Set rgG = .Range("F8").Offset(, -5).Resize(, 22)
           With .Range("F8:F" & lR)
               .AutoFilter Field:=1, Criteria1:=sDK
               Set rG = .Offset(, -5).Resize(, 22).SpecialCells(xlCellTypeVisible)
           End With
   
   Set wbN = Workbooks.Add
           Set Rg2 = wbN.Sheets(1).Range("A8")
   
   rG.Copy
           Rg2.PasteSpecial xlPasteValues
           Rg2.PasteSpecial xlPasteFormats
           rgG.Copy
           Rg2.PasteSpecial xlPasteColumnWidths
   
   .AutoFilterMode = False
       End With
       With Application
           .CutCopyMode = False: .ScreenUpdating = True: .DisplayAlerts = True:   .EnableEvents = True
       End With
       t = Timer - t
       MsgBox "Thoi gian thuc hien chuong trinh:  " & t
   End Sub

   Chắc bạn biết VBA, và thạo Excel nên

   – tự thêm lệnh xóa cột nào cần bỏ đi
   – tự thêm lệnh save file
   – và chú ý nên thay các công thức SUM thay SUBTOTAL(109, ….) với tham số hàm 109 để không tính tổng các giá trị ẩn đi =======> thì kết quả tổng mới đúng.
   ví dụ M11 thành: =SUBTOTAL(109,M12:M38)+SUBTOTAL(109,M43:M45)

   Reply
10. hands says:

    08/12/2023 at 6:12 pm

    Như đã nói

    Từ code bài 1 thấy rằng mục đích chính của bạn là tạo file mới với dữ liệu lọc là không chứa các dòng mà tài cột F có giá trị PW*,

    Nên hình thành code sau (bổ sung, nâng cấp code #1 của bạn thôi) – đảm bảo tốc độ nhanh chấp nhận được, kết quả có đầy đủ định dạng format gốc

    Sub copyPppp()
        Dim t
        t = Timer
    
    Const sDK = "<>PW*"
        Dim Cll As Range
        Dim lR As Long
        Dim wbN As Workbook
        Dim rG As Range
        Dim Rg2 As Range
        Dim rgG As Range
    
    With Application
            .ScreenUpdating = False: .DisplayAlerts = False:  .EnableEvents = False
            .Calculation = xlCalculationAutomatic
        End With
    
    With ActiveSheet      
            .AutoFilterMode = False
             lR = .Cells(65000, 3).End(xlUp).Row
            Set rgG = .Range("F8").Offset(, -5).Resize(, 22)
            With .Range("F8:F" & lR)
                .AutoFilter Field:=1, Criteria1:=sDK
                Set rG = .Offset(, -5).Resize(, 22).SpecialCells(xlCellTypeVisible)
            End With
    
    Set wbN = Workbooks.Add
            Set Rg2 = wbN.Sheets(1).Range("A8")
    
    rG.Copy
            Rg2.PasteSpecial xlPasteValues
            Rg2.PasteSpecial xlPasteFormats
            rgG.Copy
            Rg2.PasteSpecial xlPasteColumnWidths
    
    .AutoFilterMode = False
        End With
        With Application
            .CutCopyMode = False: .ScreenUpdating = True: .DisplayAlerts = True:   .EnableEvents = True
        End With
        t = Timer - t
        MsgBox "Thoi gian thuc hien chuong trinh:  " & t
    End Sub

    Chắc bạn biết VBA, và thạo Excel nên

    – tự thêm lệnh xóa cột nào cần bỏ đi
    – tự thêm lệnh save file
    – và chú ý nên thay các công thức SUM thay SUBTOTAL(109, ….) với tham số hàm 109 để không tính tổng các giá trị ẩn đi =======> thì kết quả tổng mới đúng.
    ví dụ M11 thành: =SUBTOTAL(109,M12:M38)+SUBTOTAL(109,M43:M45)

    Cảm ơn anh rất nhiều, Code của anh chạy rất nhanh, Form vẫn giữ ok, nhưng anh khắc phục giúp 1 vài vấn đề sau:

    – Trong file còn nhiều Sheet khác liên kết đến, do đó không thể Paste sang 1 workbook mới được, phải Paste lại trên sheet hiện hành nha anh.
    – Chiều cao cột tăng thành 15, trong khi định dạng ban đầu có hàng 14.25, có hàng nhỏ hơn.

    Sao cột lại có chiều cao ??? chắc là dòng?

    Bạn phức tạp nhỉ, muốn thế sử dụng cách củ chuối -code sau- vẫn khá nhanh
    (chú ý khi thử chạy chương trình, nên copy 1 file lưu trước, vì không thể undo những dòng đã xoá đâu, các chú ý khác như thay SUM thành SUbtotal, xoá cột vẫn như bài trước… )

    Sub copyPppp2()
        Dim t
        t = Timer
    
    Const sDK = "<>PW*"
        Dim Cll As Range
        Dim lR As Long
        Dim wbN As Workbook
        Dim rG As Range
        Dim Rg2 As Range
        Dim rgG As Range
    
    With Application
            .ScreenUpdating = False: .DisplayAlerts = False:  .EnableEvents = False
            .Calculation = xlCalculationAutomatic
        End With
    
    With ActiveSheet
            lR = .Cells(65000, 3).End(xlUp).Row
            .AutoFilterMode = False
            Set rgG = .Range("F8:F" & lR)
            With rgG
                .AutoFilter Field:=1, Criteria1:=sDK
                Set rG = .Offset(, -5).Resize(, 22).SpecialCells(xlCellTypeVisible)
            End With
    
    If rG.Rows.Count = lR - 8 + 1 Then
                MsgBox "Khong co dong nao cot [F:F] =PW*"
                .AutoFilterMode = False
                GoTo end_
            End If
            Set wbN = Workbooks.Add
            Set Rg2 = wbN.Sheets(1).Range("A8")
    
    rG.Copy
            Rg2.PasteSpecial xlPasteValues
            Rg2.PasteSpecial xlPasteFormats
            Set Rg2 = Rg2.CurrentRegion '' .Resize(Rg2.Offset(65000, 2).End(xlUp).Row - Rg2.Row + 1, 22)
            .AutoFilterMode = False
            rgG.EntireRow.Delete
            Rg2.Copy .[A8]
            wbN.Close False
        End With
    
    t = Timer - t
        MsgBox "Thoi gian thuc hien chuong trinh:  " & t
    
    end_:
        With Application
            .CutCopyMode = False: .ScreenUpdating = True: .DisplayAlerts = True:   .EnableEvents = True
        End With
    End Sub

    Vì bạn sẽ save as sang file khác, nên code trên tốt nhất để vào 1 file trắng, đặt phím tắt (mở lên cùng khi cần chạy)

    hoặc là cho vào addins

    các cái này chắc bạn làm tốt

    Reply