Sửa code xóa dòng trống cho nhiều sheet

[pomete]

Hi mọi người,

Mình tìm kiếm được một đoạn code xóa dòng trống như sau:

Public Sub DeleteCompletelyBlankRows()
Dim R As Long
Dim C As Range
Dim N As Long
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
N = 0
For R = Rng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountA(Rng.Rows(R).EntireRow) = 0 Then
Rng.Rows(R).EntireRow.Delete
N = N + 1
End If
Next R
EndMacro:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Code này xóa được dòng trống trên 1 sheet. Do mình không biết về VBA nên không sửa được, các bạn sửa code này cho mình để có thể chạy được trên tất cả các sheet hiện hành nhé!

Thanks!

 

[hoangvuluan]

DeleteCompletelyBlankRows(AllSheets)

Hi mọi người,

Mình tìm kiếm được một đoạn code xóa dòng trống như sau:

Public Sub DeleteCompletelyBlankRows() Dim R As Long
Dim C As Range
Dim N As Long
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
N = 0
For R = Rng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountA(Rng.Rows(R).EntireRow) = 0 Then
Rng.Rows(R).EntireRow.Delete
N = N + 1
End If
Next R
EndMacro:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub




Code này xóa được dòng trống trên 1 sheet. Do mình không biết về VBA nên không sửa được, các bạn sửa code này cho mình để có thể chạy được trên tất cả các sheet hiện hành nhé!


Thanks!

Thay bằng code dưới đây, đảm bảo xóa hết tất cả các dòng trống (kể cả các dòng trống trên đầu).

Public Sub DeleteCompletelyBlankRows()
Dim R As Long, N As Long, S As Long
Dim sH As Worksheet
  On Error GoTo EndMacro
  With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    For Each sH In Worksheets
        With sH.UsedRange
            S = .Row - 1 + .Rows.Count
        End With
        ' N = 0 '
        For R = S To 1 Step -1
            If Application.WorksheetFunction.CountA(sH.Rows(R).EntireRow) = 0 Then
                sH.Rows(R).EntireRow.Delete
                ' N = N + 1 '
            End If
        Next R
    Next
EndMacro:
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
  End With
End Sub

 

[ndu96081631]

Tôi thấy rút gọn thế này cũng được mà:

Option Explicit
Sub DeleteCompletelyBlankRows()
  Dim Sh As Worksheet
  On Error Resume Next
  For Each Sh In Worksheets
     Sh.UsedRange.SpecialCells(4).EntireRow.Delete
  Next
End Sub