Delete cells and move up 2003

[kingdomb]

I'm trying to delete just A:_ & B:_ and move up if B:_ is empty. This works for the first sheet but then the second sheet stalls and I eventually have to shut down the program. Here is what I have so far.

Sub SStep2()
Sheets("1st").Select
Dim I As Long
Dim FIRSTROW As Long
Dim LASTROW As Long
Application.ScreenUpdating = False
FIRSTROW = ActiveSheet.UsedRange.Rows.Row
LASTROW = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows.Row - 1
For I = LASTROW To FIRSTROW Step -1
If (Cells(I, "B") = "") Then
Range(Cells(I, "A"), Cells(I, "B")).Delete Shift:=xlUp
End If
Next I
Application.ScreenUpdating = True

Sheets("2nd").Select
Application.ScreenUpdating = False
FIRSTROW = ActiveSheet.UsedRange.Rows.Row
LASTROW = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows.Row - 1
For I = LASTROW To FIRSTROW Step -1
If (Cells(I, "B") = "") Then
Range(Cells(I, "A"), Cells(I, "B")).Delete Shift:=xlUp
End If
Next I
Application.ScreenUpdating = True

Sheets("3rd").Select
Application.ScreenUpdating = False
FIRSTROW = ActiveSheet.UsedRange.Rows.Row
LASTROW = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows.Row - 1
For I = LASTROW To FIRSTROW Step -1
If (Cells(I, "B") = "") Then
Range(Cells(I, "A"), Cells(I, "B")).Delete Shift:=xlUp
End If
Next I
Application.ScreenUpdating = True

End Sub

 

[shg]

You might check the extents of the used range on the second sheet and make sure you haven't applied formatting or down something else that causes it to include all the rows in sheet.

Then try this:

Sub SStep2()
    Dim wks       As Worksheet
    Dim r         As Range
    Dim iRow      As Long
 
    Application.ScreenUpdating = False
 
    For Each wks In Worksheets(Array("1st", "2nd", "3rd"))
        Set r = Intersect(wks.UsedRange.EntireRow, wks.Columns("A:B"))
 
        If Not r Is Nothing Then
            For iRow = r.Rows.Count To 1 Step -1
                If IsEmpty(r(iRow, "B").Value) Then
                    r.Rows(iRow).Delete Shift:=xlUp
                End If
            Next iRow
        End If
    Next wks
 
    Application.ScreenUpdating = True
End Sub

 

[kingdomb]

You're correct! I had some sheets with endless columns and rows. I changed the formula like this though.

Dim I As Long
Dim FIRSTROW As Long
Dim LASTROW As Long
Application.ScreenUpdating = False
FIRSTROW = 7
LASTROW = 100
For I = LASTROW To FIRSTROW Step -1
If (Cells(I, "B") = "") Then
Range(Cells(I, "A"), Cells(I, "B")).Delete Shift:=xlUp
End If
Next I


Thanks.