VBA xóa dòng trùng, trống

Liên hệ QC

ThuNghi

Hãy cho rồi sẽ nhận!
Thành viên đã mất
Tham gia
16/8/06
Bài viết
3,808
Được thích
4,449
Rất cám ơn lachinhan về trang
http://www.cpearson.com/excel.htm
Trong này có một vài VBA xóa dòng trống, trùng, lấy DM, và rất nhiều hàm. (free)
Mã:
Public Sub DeleteDuplicateRows()

'[COLOR="Blue"] DeleteDuplicateRows
'chon cot can xoa gt trung[/COLOR]
 Dim R As Long,  N As Long
 Dim V As Variant ,  Rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


 Set Rng = Application.Intersect(ActiveSheet.UsedRange, _
                    ActiveSheet.Columns(ActiveCell.Column))

 Application.StatusBar = "Processing Row: " & Format(Rng.Row, "#,##0")

 N = 0
For R = Rng.Rows.Count To 2 Step -1
    If R Mod 500 = 0 Then
         Application.StatusBar = "Processing Row: " & Format(R, "#,##0")
    End If

    V = Rng.Cells(R, 1).Value
[COLOR="blue"]' Note that COUNTIF works oddly with a Variant that is equal to vbNullString.
' Rather than pass in the variant, you need to pass in vbNullString explicitly.[/COLOR]
    If V = vbNullString Then
            If Application.WorksheetFunction.CountIf(Rng.Columns(1), vbNullString) > 1 Then
                   Rng.Rows(R).EntireRow.Delete
                   N = N + 1
             End If
     Else
             If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
                   Rng.Rows(R).EntireRow.Delete
                   N = N + 1
              End If
      End If
Next R

EndMacro:

Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr(N)

End Sub
'xac dinh vung can delete
Public Sub DeleteBlankRows()

Dim R As Long
Dim C As Range
Dim Rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

If Selection.Rows.Count > 1 Then
    Set Rng = Selection
Else
    Set Rng = ActiveSheet.UsedRange.Rows
End If
For R = Rng.Rows.Count To 1 Step -1
    If Application.WorksheetFunction.CountA(Rng.Rows(R).EntireRow) = 0 Then
        ActiveSheet.Rows(R).EntireRow.Delete
    End If
Next R

EndMacro:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

PHP:
Public Sub DeleteRowOnCell()

On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.UsedRange

End Sub
 
Xin chào befaint,
Code thật là lợi hại.
Không dành cho thành viên ở #2 , kệ Oanh thơ cứ lấy dùng đấy, ở trên này tất cả đều mà free phải không ạ? hihi
Cảm ơn befaint rất nhiều.
Lưu ý một chút là với cách làm trong code, nếu dữ liệu gốc của bạn có công thức là nó sẽ bị chuyển thành giá trị hết đấy nhé. Vậy nên nếu bạn có công thức và muốn giữ nó thì bạn thay chỗ Value2 thành Formula là sẽ giải quyết được vấn đề này.
Ngoài ra, code thao tác trên mảng và gán giá trị xuống nên định dạng bảng tính sẽ không được giữ lại như ban đầu đâu.
 
Upvote 0
Web KT
Back
Top Bottom