Code tự xóa dòng (1 người xem)

[toangiaphat]

Mình muốn làm cái lệnh khi chạy sẽ tự động xóa các dòng ko có dữ liệu ở tất cả các sheet.
nhờ các Bác nghiêm cứu giúp Em

 

[befaint]

Sub Nguyen()
Application.ScreenUpdating = False
Dim ws As Worksheet, lr As Long, r As Long
For Each ws In ThisWorkbook.Worksheets
    lr = ws.Range("B65000").End(xlUp).Row
    For r = lr To 1 Step -1
        If ws.Cells(r, 2).Value = "" Then ws.Rows(r).Delete
    Next r
Next ws
Application.ScreenUpdating = True
End Sub

 

[HieuCD]

Mình muốn làm cái lệnh khi chạy sẽ tự động xóa các dòng ko có dữ liệu ở tất cả các sheet.
nhờ các Bác nghiêm cứu giúp Em

chạy code sau

Sub XoaDong()
Dim Darr(), WSh As Worksheet, Rng As Range, i As Long, j As Byte
Application.ScreenUpdating = False
For Each WSh In ThisWorkbook.Worksheets
    If WSh.Range("A65500").End(xlUp).Row < 2 Then GoTo Tiep1
    Darr = WSh.Range("A1:G" & WSh.Range("A65500").End(xlUp).Row).Value
    For i = 2 To UBound(Darr)
        For j = 1 To UBound(Darr, 2)
            If Darr(i, j) <> "" Then GoTo Tiep2
        Next j
        If Rng Is Nothing Then
            Set Rng = WSh.Range("A" & i)
        Else
            Set Rng = Union(Rng, WSh.Range("A" & i))
        End If
Tiep2:
    Next i
    If Not Rng Is Nothing Then
        Rng.EntireRow.Delete: Set Rng = Nothing
    End If
Tiep1:
Next WSh
Application.ScreenUpdating = True
End Sub

 

[phulien1902]

Mình muốn làm cái lệnh khi chạy sẽ tự động xóa các dòng ko có dữ liệu ở tất cả các sheet.
nhờ các Bác nghiêm cứu giúp Em

Bạn thử:

Sub Xoa2()
    Dim ws As Worksheet, i As Long
    For Each ws In Worksheets
        With ws.UsedRange
            For i = .Rows.Count To 1 Step -1
                If Application.WorksheetFunction.CountA(.Rows(i).EntireRow) = 0 Then
                    .Rows(i).EntireRow.Delete
                End If
            Next i
        End With
    Next ws
End Sub

 

[befaint]

Code không xóa dòng đây...

Sub Nguyen2()
Dim ws As Worksheet, rng As Range, tmp() As Variant, KQ() As Variant
Dim lr As Long, r As Long, j As Long, k As Byte, c As Byte
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
    lr = ws.Range("B65000").End(xlUp).Row
    Set rng = ws.Range("A2:G" & lr)
    tmp = rng.Value2: lr = UBound(tmp, 1): k = UBound(tmp, 2)
    ReDim KQ(1 To lr, 1 To k)
    For r = 1 To lr
        If tmp(r, 2) <> vbNullString Then
            j = j + 1
            For c = 1 To k
                KQ(j, c) = tmp(r, c)
            Next c
        End If
    Next r
    rng.Borders.LineStyle = 0
    rng.ClearContents
    rng.Cells(1, 1).Resize(j, k).Borders.LineStyle = 1
    rng.Value = KQ
    Set rng = Nothing: Erase tmp: Erase KQ: j = 0
Next ws
Application.ScreenUpdating = True
End Sub

 

[toangiaphat]

Code của bác làm em xém treo máy, mà nó ko chịu xóa. Thanks bac!
Mấy code trên chạy ok lắm!
Các ơn bác hổ trợ