deleting rows with blank cells and criteria VBA - vba

Question

I have columns from A - S, where I need to delete the headers and blank cells, my criteria for lookup in deleting headers are "Transaction" & "Source" but it seems it's skipping rows. I have a total of 79,000 rows but code only goes till 39,000. I've tried everything I can find over. still nothing happens.
I'm also starting the formatting and deleting on row 209 up to lastrow.
Option Explicit
Sub Project_M()
Dim lastrow As Long
Dim cc As Long
Dim dd As Long
lastrow = WorksheetFunction.CountA(Columns(1))
Application.ScreenUpdating = False
Call ClearFormats
lastrow = WorksheetFunction.CountA(Columns(1))
Columns(1).Insert shift:=xlToRight
Range("A209:A" & lastrow).Formula = "=ROW()" 'inserting dummy rows
Range("A209:A" & lastrow).Value = Range("A210:A" & lastrow).Value
Range("U209:U" & lastrow).Formula = "=IF(AND(ISERROR(SEARCH(""Transaction"",B209)),ISERROR(SEARCH(""Source"", B209))),1,0)"
Range("U209:U" & lastrow).Value = Range("U209:U" & lastrow).Value
''''' delete headers : only working till row 39,0000
Range("A209:U" & lastrow).Sort Key1:=Range("U209"), Order1:=xlAscending
cc = WorksheetFunction.CountIf(Columns(21), "0")
If cc <> 0 Then
Range("A209:U" & cc).Select
Range("A209:U" & cc).EntireRow.Delete
lastrow = lastrow - cc
End If
Range("A209:U" & lastrow).Sort Key1:=Range("A209"), Order1:=xlAscending
Range("U:U").ClearContents
Range("A:A").Delete
ActiveSheet.UsedRange.Columns.AutoFit
End Sub
Sub deleteBlank() 'not working
Dim lastrow As Integer
lastrow = Range("A" & rows.Count).End(xlUp).Row
Range("B2:B" & lastrow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Sub ClearFormats() ' working
Dim rng As Range
Dim lastrow As Long
Dim ws As Worksheet
lastrow = Range("A" & rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
On Error Resume Next
Set rng = Range("A209:S" & lastrow).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rng Is Nothing Then
rng.ClearFormats
End If
On Error Resume Next 'not working in deleting blank cells
ws.Columns("A209:S" & lastrow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
End Sub
Sub DeleteExtra() ' not working
Dim Last As Long
Dim i As Long
Last = Cells(rows.Count, "A").End(xlUp).Row
For i = Last To 1 Step 1
If (Cells(i, "A209").Value) = "Transaction" And (Cells(i, "A209").Value) = "Source" And (Cells(i, "A209").Value) = "" And (Cells(i, "A209").Value) = " " Then
Cells(i, "A").EntireRow.Delete
End If
Next i
End Sub
Sub deleteBlankcells() '''not working
Dim lastrow As Long
Dim cc As Long
lastrow = WorksheetFunction.CountA(Columns(1))
Range("A209:A" & lastrow).Formula = "=ROW()" 'inserting dummy rows
Range("A209:A" & lastrow).Value = Range("A210:A" & lastrow).Value
Range("U209:U" & lastrow).Formula = "=IF(AND(ISBLANK(A209),ISBLANK(A209)),0,1)"
Range("U209:U" & lastrow).Value = Range("U209:U" & lastrow).Value
Range("A209:U" & lastrow).Sort Key1:=Range("U209"), Order1:=xlAscending
cc = WorksheetFunction.CountIf(Columns(21), "0")
If cc <> 0 Then
Range("A209:U" & cc).Select
Range("A209:U" & cc).EntireRow.Delete
lastrow = lastrow - cc
End If
Range("A209:U" & lastrow).Sort Key1:=Range("A209"), Order1:=xlAscending
Range("U:U").ClearContents
Range("A:A").Delete
End Sub
I've tried different attempts but not working. codes are commented.
Thanks!

Answer 1

With the help and ideas of users, I've come to this simple code and got it working.
Credits to all of them! Cheers!
Option Explicit
Sub Project_M()
Dim Last As Long
Dim i As Long
Application.ScreenUpdating = False
Last = cells(rows.Count, "A").End(xlUp).Row
Range("A209:S" & Last).UnMerge
Range("A209:S" & Last).WrapText = False
For i = Last To 209 Step -1
If (cells(i, "A").Value) = "Source" Or (cells(i, "A").Value) = 0 Or (cells(i, "A").Value) = "End of Report" Or (cells(i, "A").Value) = "Transaction" Then
cells(i, "A").EntireRow.Delete
End If
Next i
ActiveSheet.UsedRange.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Starting from the last row of the column for i = Last up to the row I want to start my formatting and deleting To 209 and Step -1 to move up.