Solved: Delete Empty cells with condition

Hello,

OK I want to delete cells in a spreadsheet based on the contents of Column B

I am gonna word it out so you can understand:

I want to delete all rows in a spreadsheet that contain no data in column B, as long as the data in column A is not "Cookies", or "Salt". The range of cells I want to delete spams from "A7:G7". when deleting this I want to shift the cells up because there is data beyond column "G" that I want to maintain.

After the cells are deleted I will have to restore my formula(s) down until "B200:G200"

Also there is a conditional formatting rule to shade every other row that always gets messed up, I would like it restored to cover the Range "A7:G200" The formula I am using is " =MOD(ROW(),2)=1"

Then I will reset the print area, for that I made this code (not too much to brag about):

[VBA]Sub SetPrintArea()

If Not Sheets("Sheet1").Range("A34").Value = "" Then
ActiveSheet.PageSetup.PrintArea = Range("A1:N1", Range("A" & Rows.Count).End(xlUp)).Address
Else
ActiveSheet.PageSetup.PrintArea = Range("A1:N34").Address
End If

End Sub
[/VBA]

I made a small sample of my document. Not all the columns were included. Attachment 8157

Thanks any help will be more than welcome

BTW this is an updated version of my original post http://www.vbaexpress.com/forum/showthread.php?t=42305 I desided to remove the table and use normal ranges because I was having problems with my other copy paste macros. Any ways what I was looking for was the alternating row shading and i got that with my formula.

[VBA]Public Sub DeleteData()
Const FORMULA_CHECK As String = "=AND(B3="""",NOT(OR(A3={""Cookies"",""Salt""})))"
Dim rng As Range
Dim lastrow As Long
Dim i As Long

With ActiveSheet

.Columns("E").Insert
.Rows(1).Insert shift:=xlDown

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("E1").Value = "temp"
.Range("E2").Value = "FALSE"
Set rng = .Range("A1").Resize(lastrow, 5)
.Range(rng.FormatConditions(1).AppliesTo.Address).FormatConditions(1).Delet e
.Range("E3").Resize(lastrow - 2).Formula = FORMULA_CHECK
rng.AutoFilter Field:=5, Criteria1:="TRUE"
Set rng = rng.SpecialCells(xlCellTypeVisible)
rng.Delete shift:=xlUp

.Columns("E").Delete

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A2").Resize(lastrow - 1, 4)
rng.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)=1"
rng.FormatConditions(1).Interior.ColorIndex = 15
End With
End Sub[/VBA]

Hi,

Xld thanks a lot for the quick response. This works. There is only an issue I forgot to mention before

My data actually starts at range "A7:G7"

The range above that contains also some merged cells.

Also my cell K29 lost its borders

Hi,

I made a mistake. My real sheets looks a little different than mine does. So here is the updated version. I am sorry about this. But I was thinking that I was gonna get a solution using ranges and that i was going to be able to easily modify them.

Here is the file Attachment 8165


The code above is very hard for me to read or understand.

Sorry for that :(

Can you guys help me with this. I have tried to modify this but nothing seems to work.

Thanks

I tried to Modify the original code and it works. But for some reason part of my table next to the main one gets deleted.

Here is the code I got

[VBA]Public Sub DeleteData()
Const FORMULA_CHECK As String = "=AND(B7="""",NOT(OR(A7={""Cookies"",""Salt""})))"
Dim rng As Range
Dim lastrow As Long
Dim i As Long

With ActiveSheet

.Columns("J").Insert
.Rows(5).Insert shift:=xlDown

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("J5").Value = "temp"
.Range("J6").Value = "FALSE"
Set rng = .Range("A6").Resize(lastrow, 10)
.Range(rng.FormatConditions(1).AppliesTo.Address).FormatConditions(1).Delet e
.Range("J7").Resize(lastrow - 2).Formula = FORMULA_CHECK
rng.AutoFilter Field:=10, Criteria1:="TRUE"
Set rng = rng.SpecialCells(xlCellTypeVisible)
rng.Delete shift:=xlUp

.Columns("J").Delete

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A6").Resize(lastrow - 1, 9)
rng.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)=1"

rng.FormatConditions(1).Interior.ColorIndex = 15
End With
End Sub
[/VBA]

Also when I run it more than once then I get an error in this line

[VBA].Range(rng.FormatConditions(1).AppliesTo.Address).FormatConditions(1).Delet e[/VBA]

See if this works

[VBA]Public Sub DeleteData()
Const FORMULA_CHECK As String = "=AND(B<start>="""",NOT(OR(A<start>={""Cookies"",""Salt""})))"
Const FORMULA_SUBTOTAL = "=IF(B<start+>="""","""",B<start+>*ROW(B<start+>)+68)"
Const FORMULA_PCTOTAL = "=IFERROR(D<start>*0.25,"""")"
Const FORMULA_WEIGHT = "=IFERROR(D<start>-E<start+>,"""")"
Const FORMULA_TOTALWEIGHT = "=IFERROR(E<start>-F<start+>,"""")"
Const HEADER_ROW As Long = 6
Dim rng As Range
Dim lastrow As Long
Dim numcols As Long
Dim i As Long

With ActiveSheet

numcols = .Cells(HEADER_ROW, "A").End(xlToRight).Column
.Columns(numcols + 1).Insert
.Rows(HEADER_ROW).Insert shift:=xlDown

lastrow = .UsedRange.Rows.Count
.Cells(HEADER_ROW, numcols + 1).Value = "temp"
.Cells(HEADER_ROW + 1, numcols + 1).Value = "FALSE"
Set rng = .Cells(HEADER_ROW, "A").Resize(lastrow, numcols + 1)
On Error Resume Next
rng.Offset(2, 0).FormatConditions(1).Delete
On Error GoTo 0
.Cells(HEADER_ROW + 2, numcols + 1).Resize(lastrow - 2).Formula = Replace(FORMULA_CHECK, "<start>", HEADER_ROW + 2)
rng.AutoFilter Field:=numcols + 1, Criteria1:="TRUE"
Set rng = rng.SpecialCells(xlCellTypeVisible)
rng.Delete shift:=xlUp

.Columns(numcols + 1).Delete

lastrow = .UsedRange.Rows.Count
Set rng = .Cells(HEADER_ROW + 1, "A").Resize(lastrow - HEADER_ROW, numcols)
rng.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)=1"
rng.FormatConditions(1).Interior.ColorIndex = 15
.Cells(HEADER_ROW + 1, "D").Resize(lastrow - HEADER_ROW).Formula = Replace(Replace(FORMULA_SUBTOTAL, _
"<start>", HEADER_ROW + 1), _
"<start+>", HEADER_ROW + 2)
.Cells(HEADER_ROW + 1, "E").Resize(lastrow - HEADER_ROW).Formula = Replace(Replace(FORMULA_PCTOTAL, _
"<start>", HEADER_ROW + 1), _
"<start+>", HEADER_ROW + 2)
.Cells(HEADER_ROW + 1, "F").Resize(lastrow - HEADER_ROW).Formula = Replace(Replace(FORMULA_WEIGHT, _
"<start>", HEADER_ROW + 1), _
"<start+>", HEADER_ROW + 2)
.Cells(HEADER_ROW + 1, "G").Resize(lastrow - HEADER_ROW).Formula = Replace(Replace(FORMULA_TOTALWEIGHT, _
"<start>", HEADER_ROW + 1), _
"<start+>", HEADER_ROW + 2)
End With
End Sub
[/VBA]

Hi XLD,

This works but:

*The top row gets messed up again, some parts of it are deleted.

*my formula does not go all the way to row 207 so if the user wants to enter more data there is no formula

*My conditional formatting does not extended till 207 either.


I want to clean the list but leave the sheet set up so the user can input more data if chooses to. Run other macros that will bring in data from another state, ect..

Maybe I am thinking too flat but could't we just delete all the body rows (A7:I7), by shifting up so my data next to it does not get messed up. and then use a fill down from my formulas up to row 207. and then fix the range for the conditional formatting.

I don't know I think we are a little over thinking it or something.

Thanks

I don't see any headers getting messed, what are you seeing?

You can add some 'float' by adding an increment to where lastrow is calculated at the end.

Hi xld,

Sorry for the delay. Here is an example of how the cells on the side moved. Also this part of the sheet is not static, I can have two, three or more summary little tables. Some of them contain formulas relating to the original set like SUM functions etc...

here is the file with the issue : Attachment 8177

I have literally dissected your code and cannot fix it at all. I can barely understand it. But its good It has shown me several features I can use in the future.

This is totally optional, but it would be great if you explain your code a little bit to me? if you don't mind.

BTW Whats

Quote:

---

You can add some 'float' by adding an increment

---

The only information I found about it is here Blog

Thanks for the help :hi:

No problem, I am in no hurry :).

That problem is very odd, it shouldn't happen, but see if this works for you

[VBA]Public Sub DeleteData()
Const FORMULA_CHECK As String = "=AND(B<start>="""",NOT(OR(A<start>={""Cookies"",""Salt""})))"
Const FORMULA_SUBTOTAL = "=IF(B<start+>="""","""",B<start+>*ROW(B<start+>)+68)"
Const FORMULA_PCTOTAL = "=IFERROR(D<start>*0.25,"""")"
Const FORMULA_WEIGHT = "=IFERROR(D<start>-E<start+>,"""")"
Const FORMULA_TOTALWEIGHT = "=IFERROR(E<start>-F<start+>,"""")"
Const HEADER_ROW As Long = 6
Dim rngArea As Range
Dim rng As Range
Dim lastrow As Long
Dim numcols As Long
Dim i As Long

With ActiveSheet

numcols = .Cells(HEADER_ROW, "A").End(xlToRight).Column
.Columns(numcols + 1).Insert
.Rows(HEADER_ROW).Insert shift:=xlDown

lastrow = .UsedRange.Rows.Count
.Cells(HEADER_ROW, numcols + 1).Value = "temp"
.Cells(HEADER_ROW + 1, numcols + 1).Value = "FALSE"
Set rng = .Cells(HEADER_ROW, "A").Resize(lastrow, numcols + 1)
On Error Resume Next
Do While rng.Offset(2, 0).FormatConditions.Count > 0
For i = 1 To rng.Offset(2, 0).FormatConditions.Count
rng.Offset(2, 0).FormatConditions(i).Delete
Next i
Loop
On Error GoTo 0
.Cells(HEADER_ROW + 2, numcols + 1).Resize(lastrow - 2).Formula = Replace(FORMULA_CHECK, "<start>", HEADER_ROW + 2)
rng.AutoFilter Field:=numcols + 1, Criteria1:="TRUE"
Set rng = rng.SpecialCells(xlCellTypeVisible)
For Each rngArea In rng.Areas
rngArea.Delete shift:=xlUp
Next rngArea

.Columns(numcols + 1).Delete

lastrow = .UsedRange.Rows.Count + 10
Set rng = .Cells(HEADER_ROW + 1, "A").Resize(lastrow - HEADER_ROW, numcols)
rng.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)=1"
rng.FormatConditions(1).Interior.ColorIndex = 15
.Cells(HEADER_ROW + 1, "D").Resize(lastrow - HEADER_ROW).Formula = Replace(Replace(FORMULA_SUBTOTAL, _
"<start>", HEADER_ROW + 1), _
"<start+>", HEADER_ROW + 2)
.Cells(HEADER_ROW + 1, "E").Resize(lastrow - HEADER_ROW).Formula = Replace(Replace(FORMULA_PCTOTAL, _
"<start>", HEADER_ROW + 1), _
"<start+>", HEADER_ROW + 2)
.Cells(HEADER_ROW + 1, "F").Resize(lastrow - HEADER_ROW).Formula = Replace(Replace(FORMULA_WEIGHT, _
"<start>", HEADER_ROW + 1), _
"<start+>", HEADER_ROW + 2)
.Cells(HEADER_ROW + 1, "G").Resize(lastrow - HEADER_ROW).Formula = Replace(Replace(FORMULA_TOTALWEIGHT, _
"<start>", HEADER_ROW + 1), _
"<start+>", HEADER_ROW + 2)
End With
End Sub
[/VBA]

I thought after I had written it that my comment about float was unnecessarily obtuse. That article is good, but no what I was meaning. What I was referring go the spare formatted, formulated lines after your data to accommodate new entries, the float. If you look at the code, towards the end I calculate the lastrow and reinsert the formulas and add row striping. By simply incrementing that variable by say 10, the code will create a 10-row area for new items.

As for explaining it, let's get it fully working first, then I will give you a breakdown.

Thanks xld,
I cannot test the last code you provided. It makes my excel to crash.

Well it is fine here, I have no idea what the problem might be.

xld,

have you noticed that there hidden columns after "G"?

I just realized that those where not included in the code as constants. maybe that's the problem

I didn't notice that, but as I said, it worked here.

Notwithstanding, try this that handles those columns and see if it helps.

[VBA]Public Sub DeleteData()
Const FORMULA_CHECK As String = "=AND(B<start>="""",NOT(OR(A<start>={""Cookies"",""Salt""})))"
Const FORMULA_SUBTOTAL = "=IF(B<start+>="""","""",B<start+>*ROW(B<start+>)+68)"
Const FORMULA_PCTOTAL = "=IFERROR(D<start>*0.25,"""")"
Const FORMULA_WEIGHT = "=IFERROR(D<start>-E<start+>,"""")"
Const FORMULA_TOTALWEIGHT = "=IFERROR(E<start>-F<start+>,"""")"
Const FORMULA_NUMBERX As String = "=IFERROR(F<start>-G<start+>,"""")"
Const FORMULA_NUMBERY As String = "=IFERROR(G<start>-H<start+>,"""")"
Const HEADER_ROW As Long = 6
Dim rng As Range
Dim lastrow As Long
Dim numcols As Long
Dim i As Long

With ActiveSheet

.Columns("H:I").Hidden = False
numcols = .Cells(HEADER_ROW, "A").End(xlToRight).Column
.Columns(numcols + 1).Insert
.Rows(HEADER_ROW).Insert shift:=xlDown

lastrow = .UsedRange.Rows.Count
.Cells(HEADER_ROW, numcols + 1).Value = "temp"
.Cells(HEADER_ROW + 1, numcols + 1).Value = "FALSE"
Set rng = .Cells(HEADER_ROW, "A").Resize(lastrow, numcols + 1)
On Error Resume Next
Do While rng.Offset(2, 0).FormatConditions.Count > 0
For i = 1 To rng.Offset(2, 0).FormatConditions.Count
rng.Offset(2, 0).FormatConditions(i).Delete
Next i
Loop
On Error GoTo 0
.Cells(HEADER_ROW + 2, numcols + 1).Resize(lastrow - 2).Formula = Replace(FORMULA_CHECK, "<start>", HEADER_ROW + 2)
rng.AutoFilter Field:=numcols + 1, Criteria1:="TRUE"
Set rng = rng.SpecialCells(xlCellTypeVisible)
For Each rngArea In rng.Areas
rngArea.Delete shift:=xlUp
Next rngArea

.Columns(numcols + 1).Delete

lastrow = .UsedRange.Rows.Count
Set rng = .Cells(HEADER_ROW + 1, "A").Resize(lastrow - HEADER_ROW, numcols)
rng.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)=1"
rng.FormatConditions(1).Interior.ColorIndex = 15
.Cells(HEADER_ROW + 1, "D").Resize(lastrow - HEADER_ROW).Formula = Replace(Replace(FORMULA_SUBTOTAL, _
"<start>", HEADER_ROW + 1), _
"<start+>", HEADER_ROW + 2)
.Cells(HEADER_ROW + 1, "E").Resize(lastrow - HEADER_ROW).Formula = Replace(Replace(FORMULA_PCTOTAL, _
"<start>", HEADER_ROW + 1), _
"<start+>", HEADER_ROW + 2)
.Cells(HEADER_ROW + 1, "F").Resize(lastrow - HEADER_ROW).Formula = Replace(Replace(FORMULA_WEIGHT, _
"<start>", HEADER_ROW + 1), _
"<start+>", HEADER_ROW + 2)
.Cells(HEADER_ROW + 1, "G").Resize(lastrow - HEADER_ROW).Formula = Replace(Replace(FORMULA_TOTALWEIGHT, _
"<start>", HEADER_ROW + 1), _
"<start+>", HEADER_ROW + 2)
.Cells(HEADER_ROW + 1, "H").Resize(lastrow - HEADER_ROW).Formula = Replace(Replace(FORMULA_NUMBERX, _
"<start>", HEADER_ROW + 1), _
"<start+>", HEADER_ROW + 2)
.Cells(HEADER_ROW + 1, "I").Resize(lastrow - HEADER_ROW).Formula = Replace(Replace(FORMULA_NUMBERY, _
"<start>", HEADER_ROW + 1), _
"<start+>", HEADER_ROW + 2)
End With
End Sub[/VBA]

failing that, reboot :)

Nothing,

Still the same it freezes my Excel. I rebooted and I still get the same

Very odd, I just don't get that problem.

What system/Excel versions do you have?

Windows vista excel 2010

Hi xld,

I just tried the code at home. A way faster computer than the one at work. Running Windows 7 64 and Excel 2010. I still get the same, it freezes and does not respond.

:banghead:

Oh, my wife has vista so I was going to try it there, but I have 7 4-bit and Excel 2010, and no problem here. Is your Excel 64 bit or 32 bit (grasping at straws here)?

BTW, did this used to work and then the problem start happening after one particular change; which one?

Hi xld,

I posted the issue in another post and following THIS it works perfectly now. No more freezing, all the tables on the side intact. The only things that's not working now is the formulas and formatting all the way down to row 207.

This happens even thought i Added and increment to

[VBA]lastrow = .UsedRange.Rows.Count + 10[/VBA]

Also it leaves my columns "H:I" visible. This i can solve with (my humble contribution):

[VBA]ActiveSheet.Columns("H:I").Hidden = True[/VBA]

thanks for the help.

Given that your post there is not many hours ago, why not wait for a solution there. If nothing happens then post here for assistance. Hunting for a solution over many forums on the same topic gets people a bad reputation and therefore less likely to be given assistance

Hi guys, thanks a lot for the help. I am sorry Aussiebear I thought this was already kinda dead. I am very happy to know that you guys monitor the forum so users always get. I will be more patient next time.

Here is my final code. I got it from this forum

[VBA]Sub test()
Dim a, b(), i As Long, ii As Long, n As Long, flg As Boolean
With Range("a2", Range("a" & Rows.Count).End(xlUp)).Resize(, 2)
a = .Value
Redim b(1 To UBound(a, 1), 1 To UBound(a, 2))
For i = 1 To UBound(a, 1)
If a(i, 2) = "" Then
Select Case a(i, 1)
Case "Cookies", "Salt", ""
n = n + 1
flg = True
Case Else
End Select
Else
n = n + 1: flg = True
End If
If flg Then
For ii = 1 To UBound(a, 2)
b(n, ii) = a(i, ii)
Next
End If
flg = False
Next
.Value = b
End With
End Sub
[/VBA]

this is a closed threat

if worksheets("sheetname").range("b1")="" then
range("b1").delete
end if

you could use EntireRow function for Selection.Rows(row number).EntireRow.Delete

Hi rackjackson,

I cannot use that one because there is data next to this table that I do not want to delete

Sorry for the slow response. ?

Is this something along the lines that you are trying to do?

[VBA]Sub dave()
Dim cl(), lr, j, jj, val()
Application.ScreenUpdating = 0
lr = Cells(Rows.Count, 1).End(xlUp).Row
ReDim cl(1 To 2, 1 To lr)
ReDim val(1 To 2, 1 To lr)
x = 1
For i = 2 To lr
j = Cells(i, 1).Value
jj = Cells(i, 2).Value
If j = "Cookies" Or j = "Salt" Or jj <> "" Then
val(1, x + 1) = Cells(i + 1, 1).Value
If val(1, x + 1) <> "Cookies" Then
cl(1, x) = j
cl(2, x) = jj
x = x + 1
End If
End If
Next i
ReDim Preserve cl(1 To 2, 1 To x - 1)
Cells(2, 1).Resize(lr, 2).ClearContents
Cells(2, 1).Resize(x - 1, 2).Value = Application.Transpose(cl)
ActiveSheet.ListObjects("Table1").Resize Range("$A$1:$B$" & x)
Application.ScreenUpdating = 1
End Sub[/VBA]