Xoá dòng có điều kiện bằng VBA

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài

thang_nguyen1

Thành viên hoạt động
Tham gia
6/10/16
Bài viết
121
Được thích
4
Chào mọi người. Mình có file Excel trên cần xóa các điều kiện bôi vàng ở trong file Excel. Do dữ liệu có nhiều cần bỏ nên mình lọc và xóa bằng tay mất nhiều thời gian. Các bạn hỗ Dieukien.JPG
 

File đính kèm

  • Xoa Dong Co Dieu Kien.xlsm
    678.4 KB · Đọc: 10
Upvote 0
bạn thử lọc các cột có màu rồi xóa xem
Vì dữ liệu nhiều nên lọc rồi xóa lâu bạn ơi. Ý mình muốn khi chạy code nó hiện điều kiện bằng form lên mình gõ và và chạy code tiếp. Mình tìm được code nhưng chỉ được ở cột a. Còn cột khác không được
Mã:
Sub xoadongcodieukien()
Dim dc&, i&, arr1(), x, LastCol&
Dim rng As Range
Dim cnt As Long

dc = Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp).Row
ReDim arr1(1 To dc - 1, 1 To 1)
ReDim arr2(1 To dc - 1, 1 To 1)
arr1 = Sheet1.Range("A2:A" & dc).Value
x = Sheet1.Range("A1").Value
cnt = 0
With ThisWorkbook.Sheets(1)
    For i = 1 To dc - 1
        If arr1(i, 1) = x Then
            cnt = cnt + 1
            If cnt = 1 Then
                Set rng = .Rows(i + 1)
            Else
                Set rng = Union(rng, .Rows(i + 1))
            End If
        End If
    Next i
    If cnt > 0 Then
        rng.Delete
    End If
End With

End Sub
 
Upvote 0
Vì dữ liệu nhiều nên lọc rồi xóa lâu bạn ơi. Ý mình muốn khi chạy code nó hiện điều kiện bằng form lên mình gõ và và chạy code tiếp. Mình tìm được code nhưng chỉ được ở cột a. Còn cột khác không được
Thử tham khảo code cũ đã sửa 1 tí chút này xem sao:
Mã:
Option Explicit
Sub ABC()
    Dim Rng As Range, i&, t&, DK1$, DK2$, DK3$, DK4 As Range, Arr As Range
    Application.ScreenUpdating = False
    With Sheet2
        Set Arr = .Range("A1:F" & .Range("A" & Rows.Count).End(3).Row)
        DK1 = "NG"
        DK2 = "Upper Limits"
        DK3 = "Comparators"
        Set DK4 = .Range("D4")

        For i = 2 To Arr.Rows.Count 'UBound(Arr, 1)
            If Arr(i, 1) = DK2 Or Arr(i, 1) = DK3 Or Arr(i, 4) = DK4 Or Arr(i, 6) = DK1 Then
t = t + 1
                If Rng Is Nothing Then
                    Set Rng = .Rows(i & ":" & i)
                Else
                    Set Rng = Union(Rng, .Rows(i & ":" & i))
                End If
            End If
        Next i
    Rng.EntireRow.Delete
    End With
    Application.ScreenUpdating = True
MsgBox "Da xoa " & t & "dong thoa man điêu kiên"
End Sub
 
Upvote 0
Thử tham khảo code cũ đã sửa 1 tí chút này xem sao:
Mã:
Option Explicit
Sub ABC()
    Dim Rng As Range, i&, t&, DK1$, DK2$, DK3$, DK4 As Range, Arr As Range
    Application.ScreenUpdating = False
    With Sheet2
        Set Arr = .Range("A1:F" & .Range("A" & Rows.Count).End(3).Row)
        DK1 = "NG"
        DK2 = "Upper Limits"
        DK3 = "Comparators"
        Set DK4 = .Range("D4")

        For i = 2 To Arr.Rows.Count 'UBound(Arr, 1)
            If Arr(i, 1) = DK2 Or Arr(i, 1) = DK3 Or Arr(i, 4) = DK4 Or Arr(i, 6) = DK1 Then
t = t + 1
                If Rng Is Nothing Then
                    Set Rng = .Rows(i & ":" & i)
                Else
                    Set Rng = Union(Rng, .Rows(i & ":" & i))
                End If
            End If
        Next i
    Rng.EntireRow.Delete
    End With
    Application.ScreenUpdating = True
MsgBox "Da xoa " & t & "dong thoa man điêu kiên"
End Sub
Cảm ơn bạn đã hỗ trợ mình tìm ra mã Code rồi. Tiện đây mình cũng chia sẻ luôn. Nếu mã code có hạn chế gì mong các bạn hỗ trợ thêm cho mã code hoàn thiện hơn.
Mã:
Sub RemoveCondition()
Dim rng As Range
Dim InputRng As Range
Dim DeleteRng As Range
Dim DeleteStr As String

xTitleId = "X" & ChrW(243) & "a D" & ChrW(242) & "ng C" & ChrW(243) & " " & ChrW(272) & "i" & ChrW(7873) & "u Ki" & ChrW(7879) & "n"
On Error GoTo Errorhandler
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("C" & ChrW(7897) & "t C" & ChrW(7847) & "n X" & ChrW(243) & "a", xTitleId, InputRng.Address, Type:=8)
DeleteStr = Application.InputBox("T" & ChrW(7915) & " C" & ChrW(7847) & "n X" & ChrW(243) & "a", xTitleId, Type:=2)
For Each rng In InputRng
If rng.Value = DeleteStr Then
If DeleteRng Is Nothing Then
Set DeleteRng = rng
Else
Set DeleteRng = Application.Union(DeleteRng, rng)
End If
End If
Next
DeleteRng.EntireRow.Delete
Errorhandler:
End Sub
 
Upvote 0
Cảm ơn bạn đã hỗ trợ mình tìm ra mã Code rồi. Tiện đây mình cũng chia sẻ luôn. Nếu mã code có hạn chế gì mong các bạn hỗ trợ thêm cho mã code hoàn thiện hơn.
Mã:
Sub RemoveCondition()
Dim rng As Range
Dim InputRng As Range
Dim DeleteRng As Range
Dim DeleteStr As String

xTitleId = "X" & ChrW(243) & "a D" & ChrW(242) & "ng C" & ChrW(243) & " " & ChrW(272) & "i" & ChrW(7873) & "u Ki" & ChrW(7879) & "n"
On Error GoTo Errorhandler
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("C" & ChrW(7897) & "t C" & ChrW(7847) & "n X" & ChrW(243) & "a", xTitleId, InputRng.Address, Type:=8)
DeleteStr = Application.InputBox("T" & ChrW(7915) & " C" & ChrW(7847) & "n X" & ChrW(243) & "a", xTitleId, Type:=2)
For Each rng In InputRng
If rng.Value = DeleteStr Then
If DeleteRng Is Nothing Then
Set DeleteRng = rng
Else
Set DeleteRng = Application.Union(DeleteRng, rng)
End If
End If
Next
DeleteRng.EntireRow.Delete
Errorhandler:
End Sub
Code Xịn xò đấy, nhưng mà đáng tiếc là chỉ xóa được các dòng có chứa 1 điều kiện = DeleteStr, nếu là n điều kiện thì phải chạy n lần mới xóa hết.
Ví dụ : Nếu yêu cầu là vừa xóa cả dòng có chứa "NG" và "Upper Limits" hoặc thêm điều kiện nữa "Comparators" thì phải chạy nhiều lần.
Không biết bạn đã tính đến trường hợp này chưa?
Và giải pháp của bạn là gì khi bạn toán là có nhiều điều kiện cần xóa (Ví dụ: xóa các dòng có chứa "NG", hoặc "Upper Limits" hoặc "Comparators", hoặc" 2023-12-27" , hoặc.... và các "NG", hoặc "Upper Limits" hoặc "Comparators", ... nằm rải rác lung tung trên nhiều cột mà không phải là cố định trên cột biết trước.
Hy vọng là lại được chiêm ngưỡng code xịn.
 
Upvote 0
1708581009128.png


'---------------------------
SAO LƯU TRƯỚC KHI SỬ DỤNG. --=0 --=0 --=0
'---------------------------

Mã:
Sub zzz()
    On Error GoTo Thoat
    Dim ArrDK, RgU As Range
    Set VungChon = Application.InputBox("Chon NHIEU O chua cac tu can tim", , , , , , , 8)
    ReDim ArrDK(VungChon.Count)
    For Each Item In VungChon
        ArrDK(i) = Item
        i = i + 1
    Next
    CotDau = ActiveSheet.UsedRange.Column
    SoCotCanTim = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column - CotDau + 1
    DongCuoi = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    For Each Item In ArrDK
        Set selRange = Range(ActiveSheet.UsedRange.Offset(1, 0), Cells(DongCuoi, CotDau + SoCotCanTim - 1))
        With selRange
            Set RgDC = .Find(Item, LookIn:=xlFormulas)
            Set RgDCtemp = RgDC
            If Not RgDC Is Nothing Then
                If RgU Is Nothing Then
                    Set RgU = RgDC
                Else
                    Set RgU = Union(RgU, RgDC)
                End If
                Do
                    Set RgDC = .FindNext(RgDC)
                    Debug.Print RgDC.Address
                    Set RgU = Union(RgU, RgDC)
                Loop While RgDCtemp.Address <> RgDC.Address
            End If
        End With
    Next
    RgU.EntireRow.Delete
    Exit Sub
Thoat:
If Err.Number <> 0 Then
    Msg = "Error # " & Str(Err.Number) & " was generated by " _
            & Err.Source & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbMsgBoxHelpButton, "Error", Err.HelpFile, Err.HelpContext
End If
End Sub
 
Upvote 0
Code Xịn xò đấy, nhưng mà đáng tiếc là chỉ xóa được các dòng có chứa 1 điều kiện = DeleteStr, nếu là n điều kiện thì phải chạy n lần mới xóa hết.
Ví dụ : Nếu yêu cầu là vừa xóa cả dòng có chứa "NG" và "Upper Limits" hoặc thêm điều kiện nữa "Comparators" thì phải chạy nhiều lần.
Không biết bạn đã tính đến trường hợp này chưa?
Và giải pháp của bạn là gì khi bạn toán là có nhiều điều kiện cần xóa (Ví dụ: xóa các dòng có chứa "NG", hoặc "Upper Limits" hoặc "Comparators", hoặc" 2023-12-27" , hoặc.... và các "NG", hoặc "Upper Limits" hoặc "Comparators", ... nằm rải rác lung tung trên nhiều cột mà không phải là cố định trên cột biết trước.
Hy vọng là lại được chiêm ngưỡng code xịn.
Đúng rồi, cũng đang là ý của mình đang hỏi :))
 
Upvote 0
View attachment 299140


'---------------------------
SAO LƯU TRƯỚC KHI SỬ DỤNG. --=0 --=0 --=0
'---------------------------

Mã:
Sub zzz()
    On Error GoTo Thoat
    Dim ArrDK, RgU As Range
    Set VungChon = Application.InputBox("Chon NHIEU O chua cac tu can tim", , , , , , , 8)
    ReDim ArrDK(VungChon.Count)
    For Each Item In VungChon
        ArrDK(i) = Item
        i = i + 1
    Next
    CotDau = ActiveSheet.UsedRange.Column
    SoCotCanTim = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column - CotDau + 1
    DongCuoi = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    For Each Item In ArrDK
        Set selRange = Range(ActiveSheet.UsedRange.Offset(1, 0), Cells(DongCuoi, CotDau + SoCotCanTim - 1))
        With selRange
            Set RgDC = .Find(Item, LookIn:=xlFormulas)
            Set RgDCtemp = RgDC
            If Not RgDC Is Nothing Then
                If RgU Is Nothing Then
                    Set RgU = RgDC
                Else
                    Set RgU = Union(RgU, RgDC)
                End If
                Do
                    Set RgDC = .FindNext(RgDC)
                    Debug.Print RgDC.Address
                    Set RgU = Union(RgU, RgDC)
                Loop While RgDCtemp.Address <> RgDC.Address
            End If
        End With
    Next
    RgU.EntireRow.Delete
    Exit Sub
Thoat:
If Err.Number <> 0 Then
    Msg = "Error # " & Str(Err.Number) & " was generated by " _
            & Err.Source & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbMsgBoxHelpButton, "Error", Err.HelpFile, Err.HelpContext
End If
End Sub
Mình gà chưa biết sửa lại
 
Upvote 0
Mã:
Sub zzz()
' . . . .     '
        Set selRange = Range(ActiveSheet.UsedRange.Offset(1, 0), Cells(DongCuoi, CotDau + SoCotCanTim - 1))
        With selRange
            Set RgDC = .Find(Item, LookIn:=xlFormulas)
'. . . .     '
End Sub
Hình như các từ hay cụm từ cần tìm chỉ nằm trên 3 cột;
Ta có thể giới hạn khu vực cần tìm kiếm chăng, khi cần tìm 1 từ hay cụm từ cụ thể?
 
Upvote 0
View attachment 299140


'---------------------------
SAO LƯU TRƯỚC KHI SỬ DỤNG. --=0 --=0 --=0
'---------------------------

Mã:
Sub zzz()
    On Error GoTo Thoat
    Dim ArrDK, RgU As Range
    Set VungChon = Application.InputBox("Chon NHIEU O chua cac tu can tim", , , , , , , 8)
    ReDim ArrDK(VungChon.Count)
    For Each Item In VungChon
        ArrDK(i) = Item
        i = i + 1
    Next
    CotDau = ActiveSheet.UsedRange.Column
    SoCotCanTim = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column - CotDau + 1
    DongCuoi = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    For Each Item In ArrDK
        Set selRange = Range(ActiveSheet.UsedRange.Offset(1, 0), Cells(DongCuoi, CotDau + SoCotCanTim - 1))
        With selRange
            Set RgDC = .Find(Item, LookIn:=xlFormulas)
            Set RgDCtemp = RgDC
            If Not RgDC Is Nothing Then
                If RgU Is Nothing Then
                    Set RgU = RgDC
                Else
                    Set RgU = Union(RgU, RgDC)
                End If
                Do
                    Set RgDC = .FindNext(RgDC)
                    Debug.Print RgDC.Address
                    Set RgU = Union(RgU, RgDC)
                Loop While RgDCtemp.Address <> RgDC.Address
            End If
        End With
    Next
    RgU.EntireRow.Delete
    Exit Sub
Thoat:
If Err.Number <> 0 Then
    Msg = "Error # " & Str(Err.Number) & " was generated by " _
            & Err.Source & Chr(13) & Chr(13) & Err.Description
    MsgBox Msg, vbMsgBoxHelpButton, "Error", Err.HelpFile, Err.HelpContext
End If
End Sub
Code chạy với dữ liệu nhiều bị đơ và không xóa dduocj dữ liệu bạn ạ
Bài đã được tự động gộp:

Hình như các từ hay cụm từ cần tìm chỉ nằm trên 3 cột;
Ta có thể giới hạn khu vực cần tìm kiếm chăng, khi cần tìm 1 từ hay cụm từ cụ thể?
Dạ nếu có từ trên File thì bấm luôn, nếu không có thì mình gõ tay tìm kiếm ạ
 
Lần chỉnh sửa cuối:
Upvote 0
Hình như các từ hay cụm từ cần tìm chỉ nằm trên 3 cột;
Ta có thể giới hạn khu vực cần tìm kiếm chăng, khi cần tìm 1 từ hay cụm từ cụ thể?
Với bài xóa dữ liệu thì lúc mình sẽ muốn xóa từ này, lúc xóa số kia, nên em cho tìm hết luôn bác ạ.
Dữ liệu mà hàng triệu dòng cần xóa thì phải thủ công lọc rồi xóa. Hiện tớ bí với siêu dữ liệu rồi.
 
Upvote 0
Với bài xóa dữ liệu thì lúc mình sẽ muốn xóa từ này, lúc xóa số kia, nên em cho tìm hết luôn bác ạ.

Dữ liệu mà hàng triệu dòng cần xóa thì phải thủ công lọc rồi xóa. Hiện tớ bí với siêu dữ liệu rồi.
Nếu code có lọc thì sẽ ko mất thời tìm. Nghãi là lọc xong xoá.
 
Upvote 0
Web KT
Back
Top Bottom