Xóa dòng theo điều kiện

[tranphuson]

Vui lòng giúp mình xóa dòng theo điều kiện bằng VBA:

* Dựa theo ngày ở ô W1 thì xóa các dòng từ A2 đến T2 trở xuống có chứa điều kiện ngày theo ô W1

Xin cảm ơn

 

[SA_DQ]

Bạn kiểm thử theo macro sau:

Sub DongDongTheoNgay()
 Dim Dat As Date, J As Long, W As Integer, Rws As Long
 Dim Arr(), dRg As Range
 
 Dat = [w1].Value
 Rws = Sheet1.UsedRange.Rows.Count
 Arr() = [A2:T2].Resize(Rws).Value
 Set dRg = Rows(9 + Rws & ":" & Rws + 9)
 For J = 1 To UBound(Arr())
    If Arr(J, 20) = Dat Then
        W = W + 1
        Set dRg = Union(dRg, Rows(1 + J & ":" & J + 1))
    End If
 Next J
 MsgBox W
End Sub

Sau khi kiểm nếu đúng số dòng thì ta còn lệnh xóa dòng nữa là xong!

 

[tranphuson]

Bạn kiểm thử theo macro sau:

Sub DongDongTheoNgay()
 Dim Dat As Date, J As Long, W As Integer, Rws As Long
 Dim Arr(), dRg As Range
 
 Dat = [w1].Value
 Rws = Sheet1.UsedRange.Rows.Count
 Arr() = [A2:T2].Resize(Rws).Value
 Set dRg = Rows(9 + Rws & ":" & Rws + 9)
 For J = 1 To UBound(Arr())
    If Arr(J, 20) = Dat Then
        W = W + 1
        Set dRg = Union(dRg, Rows(1 + J & ":" & J + 1))
    End If
 Next J
 MsgBox W
End Sub

Sau khi kiểm nếu đúng số dòng thì ta còn lệnh xóa dòng nữa là xong!

Xin lỗi đã phản hồi trễ. Mình thấy đoạn code này thông báo đúng -> chỉ thêm lệnh xóa dòng nữa là quá tốt

Cảm ơn trước

 

[bebo021999]

Một cách khác: Bạn chỉ cần thay đổi ô W1 và kết quả sẽ tự thay đổi
(Code này đặt trong worksheet module, không đặt trong general module)

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range, U As Range
If Target.Address(0, 0) <> "W1" Then Exit Sub
For Each cell In Range("T2:T" & Cells(Rows.Count, "T").End(xlUp).Row)
    If cell.Value = Target Then
        If U Is Nothing Then
            Set U = cell
        Else
            Set U = Union(U, cell)
        End If
    End If
Next
If U Is Nothing Then
    MsgBox "Khong tim thay!"
    Exit Sub
End If
U.Select
If MsgBox("Co " & U.Rows.Count & " dong sap sua bi delete. Ban co muon tiep tuc khong? ", vbYesNo) = vbNo Then
    Range("W1").Select
    Exit Sub
End If
U.EntireRow.Delete
Range("W1").Select
End Sub

 

[tranphuson]

Một cách khác: Bạn chỉ cần thay đổi ô W1 và kết quả sẽ tự thay đổi
(Code này đặt trong worksheet module, không đặt trong general module)

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range, U As Range
If Target.Address(0, 0) <> "W1" Then Exit Sub
For Each cell In Range("T2:T" & Cells(Rows.Count, "T").End(xlUp).Row)
    If cell.Value = Target Then
        If U Is Nothing Then
            Set U = cell
        Else
            Set U = Union(U, cell)
        End If
    End If
Next
If U Is Nothing Then
    MsgBox "Khong tim thay!"
    Exit Sub
End If
U.Select
If MsgBox("Co " & U.Rows.Count & " dong sap sua bi delete. Ban co muon tiep tuc khong? ", vbYesNo) = vbNo Then
    Range("W1").Select
    Exit Sub
End If
U.EntireRow.Delete
Range("W1").Select
End Sub

Cảm ơn bạn, số dòng được xóa là chính xác nhưng thông báo thì lại không đúng -> Vì tổng số dòng ngày 18/4 là 309 dòng (xen kẽ) nhưng code chỉ hiểu là số dòng ngày liên tục chỉ có 26 dòng

 

[SA_DQ]

Xin lỗi đã phản hồi trễ. Mình thấy đoạn code này thông báo đúng -> chỉ thêm lệnh xóa dòng nữa là quá tốt

Cảm ơn trước

Lệnh xóa thì đơn giản thôi:

 dRng.Delete

 

[bebo021999]

Cảm ơn bạn, số dòng được xóa là chính xác nhưng thông báo thì lại không đúng -> Vì tổng số dòng ngày 18/4 là 309 dòng (xen kẽ) nhưng code chỉ hiểu là số dòng ngày liên tục chỉ có 26 dòng

OK. Vậy thêm 1 biến đếm c nhé

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c&, cell As Range, U As Range
If Target.Address(0, 0) <> "W1" Then Exit Sub
For Each cell In Range("T2:T" & Cells(Rows.Count, "T").End(xlUp).Row)
    If cell.Value = Target Then
        c = c + 1
        If U Is Nothing Then
            Set U = cell
        Else
            Set U = Union(U, cell)
        End If
    End If
Next
If U Is Nothing Then
    MsgBox "Khong tim thay!"
    Exit Sub
End If
U.Select
If MsgBox("Co " & c & " dong sap sua bi delete. Ban co muon tiep tuc khong? ", vbYesNo) = vbNo Then
    Range("W1").Select
    Exit Sub
End If
U.EntireRow.Delete
Range("W1").Select
End Sub

 

[tranphuson]

Lệnh xóa thì đơn giản thôi:

 dRng.Delete

Xin cảm ơn đã giúp

Bài đã được tự động gộp: 22/4/24

OK. Vậy thêm 1 biến đếm c nhé

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c&, cell As Range, U As Range
If Target.Address(0, 0) <> "W1" Then Exit Sub
For Each cell In Range("T2:T" & Cells(Rows.Count, "T").End(xlUp).Row)
    If cell.Value = Target Then
        c = c + 1
        If U Is Nothing Then
            Set U = cell
        Else
            Set U = Union(U, cell)
        End If
    End If
Next
If U Is Nothing Then
    MsgBox "Khong tim thay!"
    Exit Sub
End If
U.Select
If MsgBox("Co " & c & " dong sap sua bi delete. Ban co muon tiep tuc khong? ", vbYesNo) = vbNo Then
    Range("W1").Select
    Exit Sub
End If
U.EntireRow.Delete
Range("W1").Select
End Sub

Đoạn code này đã đúng số dòng xóa so với thông báo, xin cảm ơn