Sử dụng VBA để xóa nhiều dòng dữ liệu thừa trong Excel

[Phạm Trung Tùng Lâm]

Dear all
Em có một file Data như dưới, em nhờ các bác viết hộ em Code VBA để xóa các dòng dữ liệu thừa dựa theo các tiêu chuẩn:
- Tiêu chuẩn 1 : Revup Enable Flag = NO và Parts Text chứa "P.W.BOARD"
- Tiêu chuẩn 2 : Revup Enable Flag = NO và Quantity = 0

Mong muốn: Khi tìm được dòng Data giống tiêu chuẩn, lệnh này sẽ xóa toàn bộ dữ liệu của các dòng liền sau nó mà có Level > Level của dòng vừa tìm được.
VD:
Dòng 4 (bôi vàng) có Revup Enable Flag = NO và Parts Text chứa "P.W.BOARD", Level của nó là 2
Thì lệnh VBA sẽ xóa toàn bộ dòng có dữ liệu liền sau nó, có Level > 2 (bôi xám), cho đến dòng có Level <= 2



Em cảm ơn mọi người

 

[bebo021999]

Gán code này cho nút XÓA

Option Explicit
Sub delete()
Dim lr&, cell As Range, cellb As Range
lr = Cells(Rows.Count, "D").End(xlUp).Row
On Error Resume Next
For Each cell In Range("D2:D" & lr)
    If cell.Value = "NO" Then
        If cell.Offset(0, 6).Value Like "P.W.BOARD *" Or cell.Offset(0, 1).Value = 0 Then
            cell.Value = "#N/A"
            For Each cellb In Range(cell.Offset(1, -3), "A" & lr)
                If cellb.Value <= cell.Offset(0, -3).Value Then
                    GoTo z:
                Else:
                    cellb.Offset(0, 3).Value = "#N/A"
                End If
            Next
        End If
    End If
z:
Next
Range("D2:D" & lr).SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.delete
End Sub

 

[Phạm Trung Tùng Lâm]

Em cảm ơn nhiều ạ
Mà bác ơi, lệnh này sẽ ra kết quả như sau:


Nhưng em mong muốn giữ lại cả 2 dòng bôi vàng và 2 dòng bôi hồng (như hình dưới ạ). Bác giúp em với ạ


Em xin cảm ơn

 

[SA_DQ]

Vậy là BeBo nhà ta phải lên sa bàn trận địa thêm 1 khâu nữa rồi: Đó là ghi thêm các dòng có mức ở cột "A" <= mức đã ghi trong tham biến ở dòng đạt 1 trong 2 điều kiện: (Đ/k):
Đ/K 1: Cột 4 là "NO" & cột 6 là chuỗi "XYZ"
Đ/K 2: Cột 4 là "NO" & cột 5 = 0

 

[SA_DQ]

. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .

 

[vanthinh3101]

Dear all
Em có một file Data như dưới, em nhờ các bác viết hộ em Code VBA để xóa các dòng dữ liệu thừa dựa theo các tiêu chuẩn:
- Tiêu chuẩn 1 : Revup Enable Flag = NO và Parts Text chứa "P.W.BOARD"
- Tiêu chuẩn 2 : Revup Enable Flag = NO và Quantity = 0

Mong muốn: Khi tìm được dòng Data giống tiêu chuẩn, lệnh này sẽ xóa toàn bộ dữ liệu của các dòng liền sau nó mà có Level > Level của dòng vừa tìm được.
VD:
Dòng 4 (bôi vàng) có Revup Enable Flag = NO và Parts Text chứa "P.W.BOARD", Level của nó là 2
Thì lệnh VBA sẽ xóa toàn bộ dòng có dữ liệu liền sau nó, có Level > 2 (bôi xám), cho đến dòng có Level <= 2

View attachment 278655

Em cảm ơn mọi người

Tôi định dùng 1 vòng lặp cho dữ liệu gốc nhưng thấy hơi khó nên xoay sang hướng khác.
- Chạy vòng lặp đầu để xác định các chỉ số dòng cần xóa, đưa vào mảng 1 chiều.
- Chạy vòng lặp thứ 2 để lấy kết quả
Bạn tham khảo code sau:

Sub DeleteRows()
    Dim sArr(), ColArr(), Res()
    Dim lR As Long, I As Long, J As Long, K As Long
    Dim nCol As Byte, Col As Byte, R As Long
    
    Application.ScreenUpdating = False
    'Dong cuoi cung co du lieu
    lR = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
    'Mang 2 chieu chua toan bo du lieu goc
    sArr() = Sheet1.Range("A1:O" & lR).Value
    R = UBound(sArr, 1): nCol = UBound(sArr, 2)
    
    'Chay vong lap tu dong thu 2 den cuoi de kiem tra
    For I = 2 To R
        If sArr(I, 4) = "NO" Then
            If sArr(I, 10) = "P.W.BOARD TEST" Or sArr(I, 5) = 0 Then
                'Kiem tra cac dong ke tiep
                If I < R Then
                    'Neu dong dang kiem tra khong phai dong cuoi cung
                    For J = 1 To (R - I)
                        'Kiem tra Level lon hon dong truoc hay khong?
                        If sArr(I + J, 1) > sArr(I, 1) Then
                            K = K + 1
                            ReDim Preserve ColArr(1 To K)
                            'Dua chi so dong vao mang ket qua
                            ColArr(K) = I + J
                        Else
                            'Thoat vong lap
                            Exit For
                        End If
                    Next J
                    'Dieu chinh gia tri cua I
                    I = I + J
                End If
            End If
        End If
    Next I
    
    'Chay lai vong lap de lay ket qua
    K = 0
    ReDim Res(1 To R, 1 To nCol)
    For I = 1 To R
        'Chi so dong khong nam trong mang ColArr
        If IsError(Application.Match(I, ColArr, 0)) Then
            K = K + 1
            For Col = 1 To nCol
                Res(K, Col) = sArr(I, Col)
            Next Col
        End If
    Next I
    
    'Xoa ket qua cu
    Sheet1.Range("Q1").Resize(65000, nCol).ClearContents
    'Dien ket qua moi ra bang tinh
    Sheet1.Range("Q1").Resize(K, nCol) = Res
    
    Application.ScreenUpdating = True
    
    MsgBox "Done", vbInformation, "GPE"
    
End Sub

 

[bebo021999]

Bỏ bớt 1 dòng đi thôi:

Option Explicit
Sub delete()
Dim lr&, cell As Range, cellb As Range
lr = Cells(Rows.Count, "D").End(xlUp).Row
On Error Resume Next
For Each cell In Range("D2:D" & lr)
    If cell.Value = "NO" Then
        If cell.Offset(0, 6).Value Like "P.W.BOARD *" Or cell.Offset(0, 1).Value = 0 Then
            'cell.Value = "#N/A"
            For Each cellb In Range(cell.Offset(1, -3), "A" & lr)
                If cellb.Value <= cell.Offset(0, -3).Value Then
                    GoTo z:
                Else:
                    cellb.Offset(0, 3).Value = "#N/A"
                End If
            Next
        End If
    End If
z:
Next
Range("D2:D" & lr).SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.delete
End Sub
[/code]