PDA

View Full Version : VBA code to delete row that meets certain condition



nnick
08-11-2015, 10:42 AM
I am trying to use VBA to delete rows within a user selected range and user selected string with an inputbox.

But I have a problem, the code I have works but there are some instances where the user selected string is in row which contain data in column "I" that I need to keep but still clear the rest of the data in the row within columns A through H.

Does anyone know what I can add to the code to allow me to delete the entire row if column I is empty but if it's populated, delete everything in the row but the contents of column I.


Sub DeleteRowsWithinRange()




Dim rng As Range
Dim InputRng As Range
Dim DeleteRng As Range
Dim DeleteStr As String




xTitleIdRng = "Range"
xTitleIdDel = "Delete Text"




Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Range :", xTitleIdRng, InputRng.Address, Type:=8)
DeleteStr = Application.InputBox("Delete Text", xTitleIdDel, Type:=2)
For Each rng In InputRng
If rng.Value = DeleteStr Then
If DeleteRng Is Nothing Then
Set DeleteRng = rng
Else
Set DeleteRng = Application.Union(DeleteRng, rng)
End If
End If
Next
DeleteRng.EntireRow.Delete
End Sub

p45cal
08-11-2015, 01:14 PM
untested, try:
Sub DeleteRowsWithinRange()
Dim rng As Range
Dim InputRng As Range
Dim DeleteRng As Range, DeleteRng2 As Range
Dim DeleteStr As String

xTitleIdRng = "Range"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Range :", xTitleIdRng, InputRng.Address, Type:=8)
DeleteStr = Application.InputBox("Delete Text", xTitleIdDel, Type:=2)
For Each rng In InputRng
If rng.Value = DeleteStr Then
If IsEmpty(rng.EntireRow.Cells(9).Value) Then
If DeleteRng Is Nothing Then Set DeleteRng = rng Else Set DeleteRng = Application.Union(DeleteRng, rng)
Else
If DeleteRng2 Is Nothing Then Set DeleteRng2 = Union(Cells("A" & rng.Row & ":H" & rng.Row), Cells("J" & rng.Row & ":ZZ" & rng.Row)) Else Set DeleteRng2 = Application.Union(DeleteRng2, Union(Cells("A" & rng.Row & ":H" & rng.Row), Cells("J" & rng.Row & ":ZZ" & rng.Row)))
End If
End If
Next
If Not DeleteRng2 Is Nothing Then DeleteRng2.ClearContents
If Not DeleteRng Is Nothing Then DeleteRng.EntireRow.Delete
End Sub

nnick
08-12-2015, 05:59 AM
untested, try:
Sub DeleteRowsWithinRange()
Dim rng As Range
Dim InputRng As Range
Dim DeleteRng As Range, DeleteRng2 As Range
Dim DeleteStr As String

xTitleIdRng = "Range"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Range :", xTitleIdRng, InputRng.Address, Type:=8)
DeleteStr = Application.InputBox("Delete Text", xTitleIdDel, Type:=2)
For Each rng In InputRng
If rng.Value = DeleteStr Then
If IsEmpty(rng.EntireRow.Cells(9).Value) Then
If DeleteRng Is Nothing Then Set DeleteRng = rng Else Set DeleteRng = Application.Union(DeleteRng, rng)
Else
If DeleteRng2 Is Nothing Then Set DeleteRng2 = Union(Cells("A" & rng.Row & ":H" & rng.Row), Cells("J" & rng.Row & ":ZZ" & rng.Row)) Else Set DeleteRng2 = Application.Union(DeleteRng2, Union(Cells("A" & rng.Row & ":H" & rng.Row), Cells("J" & rng.Row & ":ZZ" & rng.Row)))
End If
End If
Next
If Not DeleteRng2 Is Nothing Then DeleteRng2.ClearContents
If Not DeleteRng Is Nothing Then DeleteRng.EntireRow.Delete
End Sub



Thanks for the reply!! I'm just receiving a runtime error 5 and I'm not sure what's causing it yet

p45cal
08-12-2015, 06:39 AM
Oops, change all 4 ocurrences of Cells in this line:
If DeleteRng2 Is Nothing Then Set DeleteRng2 = Union(Cells("A" & rng.Row & ":H" & rng.Row), Cells("J" & rng.Row & ":ZZ" & rng.Row)) Else Set DeleteRng2 = Application.Union(DeleteRng2, Union(Cells("A" & rng.Row & ":H" & rng.Row), Cells("J" & rng.Row & ":ZZ" & rng.Row)))
to Range, leaving:
If DeleteRng2 Is Nothing Then Set DeleteRng2 = Union(Range("A" & rng.Row & ":H" & rng.Row), Range("J" & rng.Row & ":ZZ" & rng.Row)) Else Set DeleteRng2 = Application.Union(DeleteRng2, Union(Range("A" & rng.Row & ":H" & rng.Row), Range("J" & rng.Row & ":ZZ" & rng.Row)))