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

thang_nguyen1 · 21/2/24

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ỗ

BuiQuangThuan · 21/2/24

thang_nguyen1 đã viết:
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ỗ View attachment 299125

bạn thử lọc các cột có màu rồi xóa xem

thang_nguyen1 · 21/2/24

BuiQuangThuan đã viết:
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

HUONGHCKT · 21/2/24

thang_nguyen1 đã viết:
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

thang_nguyen1 · 22/2/24

HUONGHCKT đã viết:

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

HUONGHCKT · 22/2/24

thang_nguyen1 đã viết:

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.

cantl · 22/2/24

thang_nguyen1 đã viết:
nó hiện

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

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

thang_nguyen1 · 22/2/24

HUONGHCKT đã viết:
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

)

thang_nguyen1 · 22/2/24

cantl đã viết:

View attachment 299140

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

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

cantl · 22/2/24

thang_nguyen1 đã viết:
Mình gà chưa biết sửa lại

Chạy code, chọn các ô tô vàng bằng Ctrl và lick chuột.

thang_nguyen1 · 22/2/24

cantl đã viết:
Chạy code, chọn các ô tô vàng bằng Ctrl và lick chuột.

Đc rồi. Nãy cứ bi lỗi nên mình loay hoay mãi ko chạy được code

SA_DQ · 22/2/24

cantl đã viết:

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ể?

thang_nguyen1 · 22/2/24

cantl đã viết:

View attachment 299140

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

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: 22/2/24

SA_DQ đã viết:
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 ạ

cantl · 22/2/24

SA_DQ đã viết:
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 ạ.

thang_nguyen1 đã viết:
dữ liệu nhiều

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.

thang_nguyen1 · 22/2/24

cantl đã viết:
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á.

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

thang_nguyen1

Thành viên hoạt động

File đính kèm

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

thang_nguyen1

Thành viên hoạt động

HUONGHCKT

Zalo 0986997214

thang_nguyen1

Thành viên hoạt động

HUONGHCKT

Zalo 0986997214

cantl

!!! Giải thoát !!!

thang_nguyen1

Thành viên hoạt động

thang_nguyen1

Thành viên hoạt động

cantl

!!! Giải thoát !!!

thang_nguyen1

Thành viên hoạt động

SA_DQ

/(hông là gì!

thang_nguyen1

Thành viên hoạt động

cantl

!!! Giải thoát !!!

thang_nguyen1

Thành viên hoạt động

Bài viết mới nhất

Facebook

Group

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng