VBA Excel AutoFilter Error - vba

I am getting following error when trying to auto filter in vba:
The object invoked has disconnected from its clients.
So what i am trying to do is auto filter, search for empty spaces and delete the rows. Can anyone please help?
I have tried the standard solutions provided online e.g. option explicit etc but to no avail.
Data:
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lngLastRow As Long
Dim lngLastRowD As Long
Application.ScreenUpdating = False
'Concatenate the Row A and B
lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Worksheets(1).Range("D2:D" & lngLastRow).Value = Evaluate("=A2:A" & lngLastRow & "&""""&" & "B2:B" & lngLastRow)
lngLastRowD = Worksheets(1).Cells(Rows.Count, "D").End(xlUp).Row
Set ws = Worksheets(1)
Set Rng = Worksheets(1).Range("A2:A" & lngLastRowD)
With Rng
.AutoFilter field:=1, Criteria1:=""
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
ws.AutoFilterMode = False
Application.ScreenUpdating = True
ThisWorkbook.Sheets(1).Range("A2").Select
End Sub

Since Worksheets() want the name of the sheet, like "Sheet1", use sheets(1).
Why are you creating the variable ws and rng when you only use them once
I ran this and it deleted rows with no data in column A.
Private Sub Worksheet_Change()
Dim lngLastRow As Long
Dim lngLastRowD As Long
Application.ScreenUpdating = False
'Concatenate the Row A and B
lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
sheets(1).Range("D2:D" & lngLastRow).Value = Evaluate("=A2:A" & lngLastRow & "&""""&" & "B2:B" & lngLastRow)
lngLastRowD = Worksheets(1).Cells(Rows.Count, "D").End(xlUp).Row
With sheets(1).Range("A2:A" & lngLastRowD)
.AutoFilter field:=1, Criteria1:=""
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
sheets(1).AutoFilterMode = False
Application.ScreenUpdating = True
Sheets(1).Range("A2").Select
End Sub

In the end i restored in approaching the issue from another angle:
Dim i As Integer, counter As Integer
i = 2
For counter = 1 To lngLastRowD
If Worksheets(1).Range("A2:A" & lngLastRowD).Cells(i) = "" And Worksheets(1).Range("D2:D" & lngLastRowD).Cells(i) <> "" Then
Worksheets(1).Range("A2:A" & lngLastRowD).Range("A" & i & ":D" & lngLastRowD).Select
Selection.Delete
GoTo TheEND
Else
i = i + 1
Debug.Print "i is " & i
End If
Next

Related

Excel VBA Find Row, copy contents, paste in next sheet then delete original data

I'm working to identify rows in sheet 1 that are not blank in column A and don't have a Y or L in column V. Then I need to copy the contents of that row, then paste values to an open row on the next worksheet. Lastly, I need to clear contents on the original sheet for that row. I'm getting stuck when it comes time to paste. Error 1004 - Method 'Range' of object'_Worksheet' failed. I appreciate any help.
Option Explicit
Option Compare Text
Sub EndMove()
Dim rowCount As Long, i As Long
Dim ws As Worksheet: Set ws = ActiveSheet
ws.Range("A11").Select
rowCount = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
Application.ScreenUpdating = False: Application.EnableEvents = False
Call ShowAllRecords
For i = 11 To rowCount
If ws.Range("V" & i) <> "y" And ws.Range("V" & i) <> "l" Then
If ws.Range("A" & i) <> "" Then
Dim rowCount2 As Long, j As Long
Dim sRng As Range
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets(ActiveSheet.Index + 1)
Dim wAct As Worksheet
Dim lRow As Long
Dim End_Row As Long
Set wAct = ws
Set sRng = ws.Range("V" & i)
If Not IsDate("01 " & wAct.Name & " 2017") Or wAct.Name = "Dec" Then MsgBox "Not applicable for this sheet.": Exit Sub
If ActiveSheet.Index = ThisWorkbook.Worksheets.Count Then MsgBox "This is the last worksheet cannot move forward.": Exit Sub
wAct.unprotect
With ws2
.unprotect
If rowCount2 = "1" Then
For j = 11 To Rows.Count
If .Range("A" & j) = "" Then
End_Row = j
Exit For
End If
Next j
Else
End If
wAct.Range("A" & sRng.row & ":AD" & sRng.row + sRng.Rows.Count - 1).Copy
.Range("A" & End_Row).PasteSpecial xlPasteValuesAndNumberFormats
wAct.Range("A" & sRng.row & ":AD" & sRng.row + sRng.Rows.Count - 1).ClearContents
.Range("A1000").Value = End_Row
.protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
End With
wAct.protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
Application.CutCopyMode = False
End If
End If
Next i
Application.EnableEvents = True: Application.ScreenUpdating = True
Call FilterBlanks
MsgBox "Move Complete"
End If
End Sub
It seems there is no line in your code that would assign value to rowCount2. So when you check it in code below it gives always false and therefore skips this part
If rowCount2 = "1" Then
For j = 11 To Rows.Count
If .Range("A" & j) = "" Then
End_Row = j
Exit For
End If
Next j
Else
but that part is essential as it is the only part where End_Row is assigned value. So then when you try to do this .Range("A" & End_Row) there is nothing in End_Row. Set up a breakpoint on that line and check Locals screen for End_Row to make sure it is this.

Vba deleting all data

I am new to vba and have written some code to delete specific data and refresh 2 pivot tables. It works fine when I step through each sub but when I add the module to a button so everything is run with the press of the button all the data is deleted.
Below is the code I have written( might be a bit cumbersome but I am still learning). I Hope someone can help me.
Sub Deleteheader()
ActiveWindow.FreezePanes = False
Rows("1:4").Select
Selection.Delete Shift:=xlUp
End Sub
Sub DeleteColumns()
Dim wsAvlRpt As Worksheet, wsSetUp As Worksheet
Set wsAvlRpt = ActiveWorkbook.Worksheets("AvlRpt")
Set wsSetUp = ActiveWorkbook.Worksheets("SetUp")
ColTotal = wsAvlRpt.UsedRange.Column + wsAvlRpt.UsedRange.Columns.Count - 1
LastCol = Split(Cells(1, ColTotal).Address, "$")(1)
For i = 1 To ColTotal
ColumnName = wsAvlRpt.Cells(1, i)
Values = wsSetUp.Range("A" & Rows.Count).End(xlUp).Row
cntColName = Application.CountIf(wsSetUp.Range("A2:A" & Values), ColumnName)
If cntColName = 0 Then
wsAvlRpt.Columns(i).EntireColumn.Delete
i = i - 1
ColTotal = ColTotal - 1
End If
If ColTotal <= i Then
Exit For
End If
Next i
wsAvlRpt.Columns(7).EntireColumn.Insert
wsAvlRpt.Range("G1").Value = "Item Desc"
Columns("G:G").Select
Selection.NumberFormat = "General"
End Sub
Public Sub DeleteStatus()
Dim wsAvlRpt As Worksheet
Dim lngLastRow As Long
Dim rngAvl As Range
Set wsAvlRpt = ThisWorkbook.Worksheets("AvlRpt")
With wsAvlRpt
lngLastRow = .Range("C" & .Rows.Count).End(xlUp).Row
Set rngAvl = .Range("A2:J" & lngLastRow)
End With
Application.DisplayAlerts = False
With rngAvl
.AutoFilter field:=8, _
Criteria1:="Ongoing", _
Operator:=xlOr, _
Criteria2:="P.Label"
.Offset(0).Resize(.Rows.Count).SpecialCells(xlCellTypeVisible).Rows.Delete
End With
Application.DisplayAlerts = True
With wsAvlRpt
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
End With
End Sub
Sub DeleteZeroInventory()
Dim wsAvlRpt As Worksheet, wsSetUp As Worksheet
Set wsAvlRpt = ActiveWorkbook.Worksheets("AvlRpt")
Set wsSetUp = ActiveWorkbook.Worksheets("SetUp")
cntZeroInventory = Application.CountIf(wsAvlRpt.Range("I:I"), "<=0.0")
If cntZeroInventory > 0 Then
Total = wsAvlRpt.Cells(Rows.Count, "A").End(xlUp).Row
wsAvlRpt.Range("$A1:J" & Total).AutoFilter field:=9, Criteria1:="<=0.0", _
Operator:=xlFilterValues
wsAvlRpt.Range("A2:J" & Total).Select
Selection.SpecialCells(xlCellTypeVisible).EntireRow.Delete
wsAvlRpt.ShowAllData
wsAvlRpt.Columns(10).EntireColumn.Insert
wsAvlRpt.Range("J1").Value = "Available Eaches"
End If
End Sub
Sub CalcEaches()
Dim LastRow As Long
Sheets("AvlRpt").Activate
LastRow = Range("I65536").End(xlUp).Row
Range("I2:I" & LastRow).Select
Selection.Offset(0, 1).Select
Selection.FormulaR1C1 = "= RC[-1] *12"
Selection = Selection.Value
End Sub
Sub AddItemDesc()
With Sheets("AvlRpt")
.Range("G2:G" & .Range("C" & Rows.Count).End(xlUp).Row).Formula = _
"=IF(ISERROR(VLOOKUP(C2,SetUp!I:J,2,FALSE)),0,VLOOKUP(C2,SetUp!I:J,2,FALSE))"
.Range("G2:G" & .Range("A" & Rows.Count).End(xlUp).Row).Value = _
.Range("G2:G" & .Range("A" & Rows.Count).End(xlUp).Row).Value
End With
End Sub
Sub DeleteStyles()
Dim wsAvlRpt As Worksheet, wsSetUp As Worksheet
Set wsAvlRpt = ActiveWorkbook.Worksheets("AvlRpt")
Dim AvlRpt As Range
Set AvlRpt = wsAvlRpt.Range("A1", Range("A1").End(xlDown).End(xlToRight))
AvlRpt.AutoFilter field:=3, Criteria1:=Array("7A37", "8A37", "CO07", "CO81"), _
Operator:=xlFilterValues
AvlRpt.CurrentRegion.Offset(1, 0).Select
With Selection
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
If wsAvlRpt.FilterMode Then
wsAvlRpt.ShowAllData
End If
End With
End Sub
Sub ClearContents()
Worksheets("CloseoutData").Range("A2:J2000").Clear
End Sub
Sub CopyDeleteAvlRpt()
Application.DisplayAlerts = False
Sheets("AvlRpt").Range("A2:J2000").Copy _
Destination:=Sheets("CloseoutData").Range("A2:J2000")
Sheets("AvlRpt").Delete
Application.DisplayAlerts = True
End Sub
Sub RefreshPivots()
ThisWorkbook.RefreshAll
End Sub
Sub PivotCopyAdults()
Dim pt As PivotTable, lRow As Long
Dim oWS_Copy As Worksheet, oWS_Paste As Worksheet
Set oWS_Copy = Sheets("Adults")
Set oWS_Paste = Sheets.Add
ActiveSheet.Name = "CloseOuts Adults"
For Each pt In oWS_Copy.PivotTables
pt.TableRange2.Copy
lRow = oWS_Paste.Cells(Rows.Count, 1).End(xlUp).Row + 1
oWS_Paste.Range("A" & lRow).PasteSpecial Paste:=xlPasteValues
oWS_Paste.Range("A" & lRow).PasteSpecial Paste:=xlPasteFormats
Next pt
oWS_Paste.Cells.Columns.AutoFit
End Sub
Sub PivotCopyYouthLadies()
Dim pt As PivotTable, lRow As Long
Dim oWS_Copy As Worksheet, oWS_Paste As Worksheet
Set oWS_Copy = Sheets("Youth&Ladies")
Set oWS_Paste = Sheets.Add
ActiveSheet.Name = "CloseOuts Youth & Ladies"
For Each pt In oWS_Copy.PivotTables
pt.TableRange2.Copy
lRow = oWS_Paste.Cells(Rows.Count, 1).End(xlUp).Row + 1
oWS_Paste.Range("A" & lRow).PasteSpecial Paste:=xlPasteValues
oWS_Paste.Range("A" & lRow).PasteSpecial Paste:=xlPasteFormats
Next pt
oWS_Paste.Cells.Columns.AutoFit
End Sub

VBA check if columns are the same

I have two Sheets in Excel that I need to check if the columns are the same in both sheets before processing them.
I have created a macro to do this check, but I'm wondering if there is a better way to achieve this.
Sub CheckColumns()
Sheets("Source1").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Sheet1").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("Source2").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Sheet1").Select
Range("A2").Select
ActiveSheet.Paste
Range("A3") = "=IF(A1=A2,0,1)"
Range("A3").Copy
Range("A2").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Range(Selection, Selection.End(xlToLeft)).Select
ActiveSheet.Paste
Range("A4") = "=SUM(3:3)"
If Range("A4").Value = 0 Then
MsgBox "Same Columns"
Else
MsgBox "different Columns"
End If
End Sub
First of all you need to avoid selection; How to avoid using Select in Excel VBA macros
Specificaally about your code; I would try comparing two arrays as it always faster to work with arrays and also it doesn't need a dummy-sheet. However, your approach, except the selection part is faster in my mind. So I would include the explicit version of your approach shortly.
Sub CheckColumns()
Dim arrS1 As Variant, arrS2 As Variant
Dim LastRow As Long
With Worksheets("Source1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
arrS1 = .Range("A1:A" & LastRow)
End With
With Worksheets("Source2")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
arrS2 = .Range("A1:A" & LastRow)
End With
If UBound(arrS1) <> UBound(arrS2) Then
MsgBox "Different Columns"
Exit Sub
End If
same = True
For i = LBound(arrS1) to UBound(arrS1)
If arrS1(i) <> arrS1(i) Then
same = False
Exit For
End If
Next i
If same = True Then
MsgBox "Same Column"
Else
MsgBox "Item " & i & " does not match. Stopped checking further"
End If
End Sub
This is the explicit version of your method:
Sub CheckColumns()
Dim rngrS1 As Range, rngS2 As Range, rngSH As Range
Dim LastRow1 As Long, LastRow2 As Long
With Worksheets("Source1")
LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rngS1 = .Range("A1:A" & LastRow)
End With
With Worksheets("Source2")
LastRow2 = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rngS2 = .Range("A1:A" & LastRow)
End With
If LastRow1 <> LastRow2 Or rngS1(1) <> rngS2(1) Then
'Second condition checks names of the columns
MsgBox "Different Columns"
Exit Sub
End If
With Worksheets("Sheet1")
Set rngSH = .Range("A1:A" & LastRow1)
End With
rngSH.Value = rngS1.Value
Set rngSH = rngSH.Offset(0,1)
rngSH.Value = rngS2.Value
Set rngSH = rngSH.Offset(0,1)
rngSH.formula "=IF(A1=B1,0,1)"
Worksheets(Sheet1).Range("D2") = "Sum(C:C)"
If Worksheets(Sheet1).Range("D2").Value <> 0 Then
MsgBox "Different Columns"
Else
MsgBox "Same Columns"
End If
End Sub
You could declare two arrays and compare that way...
Sub Compare()
Dim FirstSheet As Variant, SecondSheet As Variant
Dim a As Long, b As Long
FirstSheet = Sheets("Source1").Range("A1:" & _
Mid(Sheets("Source1").Range("A1").End(xlToRight).Address, 2, _
InStr(Right(Sheets("Source1").Range("A1").End(xlToRight).Address, _
Len(Sheets("Source1").Range("A1").End(xlToRight).Address) - 2), "$")) & 1)
SecondSheet = Sheets("Source2").Range("A1:" & _
Mid(Sheets("Source2").Range("A1").End(xlToRight).Address, 2, _
InStr(Right(Sheets("Source2").Range("A1").End(xlToRight).Address, _
Len(Sheets("Source2").Range("A1").End(xlToRight).Address) - 2), "$")) & 1)
On Error Resume Next
For a = 1 To WorksheetFunction.Max(Sheets("Source1").Range("A1:" & _
Mid(Sheets("Source1").Range("A1").End(xlToRight).Address, 2, _
InStr(Right(Sheets("Source1").Range("A1").End(xlToRight).Address, _
Len(Sheets("Source1").Range("A1").End(xlToRight).Address) - 2), "$")) & 1).Cells.Count, _
Sheets("Source1").Range("A1:" & Mid(Sheets("Source1").Range("A1").End(xlToRight).Address, 2, _
InStr(Right(Sheets("Source1").Range("A1").End(xlToRight).Address, _
Len(Sheets("Source1").Range("A1").End(xlToRight).Address) - 2), "$")) & 1))
If FirstSheet(1, a) <> SecondSheet(1, a) Then b = b + 1
Next
On Error GoTo 0
If b = 0 Then
MsgBox "Same Columns"
Else
MsgBox "different Columns"
End If
End Sub

deleting rows with blank cells and criteria VBA

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!
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.

Excel VBA delete entire row if both columns B and C are blank

I'm trying to delete an entire row in excel if column B and C are blank for that row. I have this vba code that deletes an entire row if the whole row is blank. How can I only delete the row if B and C have no value?
Thank you
Sub DeleteBlank()
Dim rng
Dim Lastrow As Integer
Set rng = Nothing
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
For Each i In Range("B1:B" & Lastrow)
If Application.CountA(i.EntireRow) = 0 Then
If rng Is Nothing Then
Set rng = i
Else
Set rng = Union(rng, i)
End If
End If
Next i
MsgBox (Lastrow)
If Not rng Is Nothing Then
rng.EntireRow.Delete
End If
End Sub
--Update--
The problem is solved. Thanks to izzymo and sous2817
Here is the current code
Sub DeleteBlank()
Dim i As Integer
Dim Lastrow As Integer
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
MsgBox (Lastrow)
For i = Lastrow To 2 Step -1
If Trim(Range("B" & i).Value) = "" And Trim(Range("C" & i).Value) = "" Then
Range("B" & i).EntireRow.Select
Selection.Delete
End If
Next i
MsgBox "Done"
End Sub
As asked for, here is a way to do it without looping:
Sub NoLoopDelete()
Dim lr As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
With Sheet1.Range("A1:I" & lr)
.AutoFilter
.AutoFilter Field:=2, Criteria1:="="
.AutoFilter Field:=3, Criteria1:="="
.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
End Sub
The results should be the same, but this way should be faster, especially if you have a lot of rows. Obviously, change the column reference to suit your layout and feel free to fancy it up w/ some error checking,etc.
Try this
Sub DeleteBlank()
Dim i as Integer
Dim Lastrow As Integer
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To Lastrow
If Trim(Range("B" & i).Value) = "" And Trim(Range("CB" & i).Value) = "" Then
Range("B" & i).EntireRow.Select
Selection.Delete
i = i - 1
End If
Next i
MsgBox "Done"
End Sub