deleting rows with blank cells and criteria 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!

The loop in DeleteExtra won't execute - it should be Step -1. — Comintern
hi @Comintern ! thanks for your response. yes I've tried Step -1 but still not working for it deletes everything. I just included it above to get idea. Thanks! — Anne
Shouldn't the If statement inside the For loop in DeleteExtra have Or nstead of And. If (Cells(i, "A").Value) = "Transaction" Or (Cells(i, "A").Value)... — nightcrawler23
Hi @nightcrawler23 I actually run it and not working with and haha. I'll try. :D — Anne
I've tried using Step -1 also the Or for sub DeleteExtra but nothing happens. — Anne

Anne Anne · Accepted Answer · 2016-12-08T05:28:40

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.

deleting rows with blank cells and criteria VBA

1 Answers