Code xóa bỏ những hàng thỏa điều kiện (1 người xem)

[alex-luu]

Chào các anh chị,
Nhờ các anh chị viết dùm 1 đoạn code để xóa bỏ những hàng nào thỏa điều kiện sau :

Nếu giá trị của 3 chữ cái đầu tiên trong cột A có xuất hiện những từ sau : ATD , BAN , CMD , DSA , TLS , ZPC thì xóa bỏ nguyên hàng đó
Nếu cột CA có xuất hiện chữ Probation Agent : xóa bỏ nguyên hàng đó.

Em xin cảm ơn các anh chị

Bài đã được tự động gộp: 5/6/21

 

[Nhattanktnn]

Chào các anh chị,
Nhờ các anh chị viết dùm 1 đoạn code để xóa bỏ những hàng nào thỏa điều kiện sau :

Nếu giá trị của 3 chữ cái đầu tiên trong cột A có xuất hiện những từ sau : ATD , BAN , CMD , DSA , TLS , ZPC thì xóa bỏ nguyên hàng đó
Nếu cột CA có xuất hiện chữ Probation Agent : xóa bỏ nguyên hàng đó.

Em xin cảm ơn các anh chị

View attachment 260105

Bài đã được tự động gộp: 5/6/21

Thử :

Option Explicit

Sub DeleteLine()
Dim Rng As Range, I&, xRng As Range, iTxtA As String, iTxtCA As String
Const txtA As String = "ATD,BAN,CMD,DSA,TLS,ZPC"
Const txtCA = "PROBATION AGENT"
With Sheets("Agent Info")
    Set Rng = .Range("A4:CA" & .Cells(Rows.Count, "A").End(xlUp).Row)
    For I = 1 To Rng.Rows.Count
        iTxtA = UCase(Left(Rng(I, 1), 3)): iTxtCA = UCase(Rng(I, 79))
        If InStr(txtA, iTxtA) Or iTxtCA = txtCA Then
            If xRng Is Nothing Then
                Set xRng = Rng(I, 1)
            Else
            Set xRng = Union(xRng, Rng(I, 1))
            End If
        End If
    Next
    xRng.Interior.Color = vbRed  'Dong nay de ban kiem tra lai, ok roi thi xoa di
    'xRng.EntireRow.Delete       'Neu thay ok roi thi cho chay lenh nay
End With
End Sub

 

[alex-luu]

Thử :

Option Explicit

Sub DeleteLine()
Dim Rng As Range, I&, xRng As Range, iTxtA As String, iTxtCA As String
Const txtA As String = "ATD,BAN,CMD,DSA,TLS,ZPC"
Const txtCA = "PROBATION AGENT"
With Sheets("Agent Info")
    Set Rng = .Range("A4:CA" & .Cells(Rows.Count, "A").End(xlUp).Row)
    For I = 1 To Rng.Rows.Count
        iTxtA = UCase(Left(Rng(I, 1), 3)): iTxtCA = UCase(Rng(I, 79))
        If InStr(txtA, iTxtA) Or iTxtCA = txtCA Then
            If xRng Is Nothing Then
                Set xRng = Rng(I, 1)
            Else
            Set xRng = Union(xRng, Rng(I, 1))
            End If
        End If
    Next
    xRng.Interior.Color = vbRed  'Dong nay de ban kiem tra lai, ok roi thi xoa di
    'xRng.EntireRow.Delete       'Neu thay ok roi thi cho chay lenh nay
End With
End Sub

Chuẩn luôn. Cảm ơn bạn rất nhiều nhé. trước giờ mình đi filter bằng tay, rất mất thời gian, hihihi

 

[alex-luu]

Chuẩn luôn. Cảm ơn bạn rất nhiều nhé. trước giờ mình đi filter bằng tay, rất mất thời gian, hihihi

Thử :

Option Explicit

Sub DeleteLine()
Dim Rng As Range, I&, xRng As Range, iTxtA As String, iTxtCA As String
Const txtA As String = "ATD,BAN,CMD,DSA,TLS,ZPC"
Const txtCA = "PROBATION AGENT"
With Sheets("Agent Info")
    Set Rng = .Range("A4:CA" & .Cells(Rows.Count, "A").End(xlUp).Row)
    For I = 1 To Rng.Rows.Count
        iTxtA = UCase(Left(Rng(I, 1), 3)): iTxtCA = UCase(Rng(I, 79))
        If InStr(txtA, iTxtA) Or iTxtCA = txtCA Then
            If xRng Is Nothing Then
                Set xRng = Rng(I, 1)
            Else
            Set xRng = Union(xRng, Rng(I, 1))
            End If
        End If
    Next
    xRng.Interior.Color = vbRed  'Dong nay de ban kiem tra lai, ok roi thi xoa di
    'xRng.EntireRow.Delete       'Neu thay ok roi thi cho chay lenh nay
End With
End Sub

Bạn ơi, mình áp dụng code của bạn qua 1 file khác , mình đã đổi tên sheet và sửa cột lại cho đúng mà sao code không hoạt động đúng, bạn giúp mình chỉnh lại chút nữa nhé


Option Explicit

Sub DeleteLine()
Dim Rng As Range, I&, xRng As Range, iTxtA As String, iTxtCA As String
Const txtA As String = "ATD,BAN,CMD,DSA,TLS,ZPC"
Const txtCA = "Lapsed"
With Sheets("Ag Info")
Set Rng = .Range("A4:CA" & .Cells(Rows.Count, "A").End(xlUp).Row)
For I = 1 To Rng.Rows.Count
iTxtA = UCase(Left(Rng(I, 1), 3)): iTxtCA = UCase(Rng(I, 10))
If InStr(txtA, iTxtA) Or iTxtCA = txtCA Then
If xRng Is Nothing Then
Set xRng = Rng(I, 1)
Else
Set xRng = Union(xRng, Rng(I, 1))
End If
End If
Next
xRng.Interior.Color = vbRed 'Dong nay de ban kiem tra lai, ok roi thi xoa di
'xRng.EntireRow.Delete 'Neu thay ok roi thi cho chay lenh nay
End With
End Sub

 

[Maika8008]

Bạn ơi, mình áp dụng code của bạn qua 1 file khác , mình đã đổi tên sheet và sửa cột lại cho đúng mà sao code không hoạt động đúng, bạn giúp mình chỉnh lại chút nữa nhé

View attachment 260972
Option Explicit

Sub DeleteLine()
Dim Rng As Range, I&, xRng As Range, iTxtA As String, iTxtCA As String
Const txtA As String = "ATD,BAN,CMD,DSA,TLS,ZPC"
Const txtCA = "Lapsed"
With Sheets("Ag Info")
Set Rng = .Range("A4:CA" & .Cells(Rows.Count, "A").End(xlUp).Row)
For I = 1 To Rng.Rows.Count
iTxtA = UCase(Left(Rng(I, 1), 3)): iTxtCA = UCase(Rng(I, 10))
If InStr(txtA, iTxtA) Or iTxtCA = txtCA Then
If xRng Is Nothing Then
Set xRng = Rng(I, 1)
Else
Set xRng = Union(xRng, Rng(I, 1))
End If
End If
Next
xRng.Interior.Color = vbRed 'Dong nay de ban kiem tra lai, ok roi thi xoa di
'xRng.EntireRow.Delete 'Neu thay ok roi thi cho chay lenh nay
End With
End Sub

Dòng này If InStr(txtA, iTxtA) Or iTxtCA = txtCA Then
Sửa thành If InStr(txtA, iTxtA) Or iTxtCA = UCase(txtCA) Then

 

[alex-luu]

Dòng này If InStr(txtA, iTxtA) Or iTxtCA = txtCA Then
Sửa thành If InStr(txtA, iTxtA) Or iTxtCA = UCase(txtCA) Then

Cảm ơn bạn. Code đã chạy tốt