Excel VBA - Why does this macro delete everything - vba

Question

I need some help with this macro. I have a workbook that is formatted pretty poorly, but consistently every time I open it. Among other things, the goal is to find the non-blank cells in column B and delete the entire 2 rows below and the 1st row above each of those populated B cells.
The first loop I have in the code works just the way I want it to, but the second loop seems to only work on the 1st instance of a populated B cell, but then it deletes everything else above it, like 500 cells worth of data.
Can someone explain to me why this is happening, and if you could find a way to combine both of those for loops into 1, that would be nice too.
Sub test()
Dim currentSht As Worksheet
Dim startCell As Range
Dim lastRow As Long, lastCol As Long
Dim colNames As Variant
Dim i As Integer, j As Integer
Set currentSht = ActiveWorkbook.Sheets(1)
Set startCell = currentSht.Range("A1")
lastRow = startCell.SpecialCells(xlCellTypeLastCell).Row
lastCol = startCell.SpecialCells(xlCellTypeLastCell).Column
For i = lastRow To 1 Step -1
If currentSht.Cells(i, "B").Value <> "" Then
currentSht.Cells(i, "B").Offset(1).EntireRow.Delete
End If
Next i
Range("D3").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlUp
currentSht.Rows("1:1").EntireRow.Delete
currentSht.Range("c:d, f:g, i:k").EntireColumn.Delete
currentSht.Range("A:D").Columns.AutoFit
For j = lastRow To 2 Step -1
If currentSht.Cells(j, "B").Value <> "" Then
currentSht.Range(Cells(j, "B").Offset(-1), Cells(j, "B").Offset(-3)).EntireRow.Delete
End If
Next j
End Sub
Thank you

Answer 1

The second loop deletes everything because upon deletion of the lines above the found value, said value gets moved up and will be found again, triggering another deletion. To fix this, the quickest way would be to skip the next two lines by modifying j:
For j = lastRow To 2 Step -1
If currentSht.Cells(j, "B").Value <> "" Then
currentSht.Range(Cells(j, "B").Offset(-1), Cells(j, "B").Offset(-3)).EntireRow.Delete
j = j - 2
End If
Next j
It really doesn't matter much if you are looping from top to bottom or vice versa. The only difference would be if there are two entries in column B near each other. In that case, the search order would determine which one is deleted. But is deletion really what you want? Maybe you could .Clear the contents of the rows instead of deleting them.
edit: here's the new code a bit cleaned up
Sub test()
Dim currentSht As Worksheet
Dim startCell As Range
Dim lastRow As Long, lastCol As Long
Dim colNames As Variant
Dim i As Integer, j As Integer
Set currentSht = ActiveWorkbook.Sheets(1)
Set startCell = currentSht.Range("A1")
lastRow = startCell.SpecialCells(xlCellTypeLastCell).Row
lastCol = startCell.SpecialCells(xlCellTypeLastCell).Column
For i = lastRow To 1 Step -1
If currentSht.Cells(i, "B").value <> "" Then
'reference the row directly
currentSht.Rows(i + 1).Delete
End If
Next i
'Do not use selection if you can avoid it
Range("D3", Range("D3").End(xlToRight)).Delete Shift:=xlUp
currentSht.Rows(1).Delete
currentSht.Range("C:D, F:G, I:K").Delete
currentSht.Range("A:D").Columns.AutoFit
For j = lastRow To 2 Step -1
If currentSht.Cells(j, "B").value <> "" Then
currentSht.Rows(j - 1).Delete
currentSht.Rows(j - 2).Delete
j = j - 2
End If
Next j
End Sub
If you want to combine the loops the behavior of the macro will change because of the deletions that happen between the loops.