Solved: Find cell with text and delete if it matches with next one

[dani9]

Hi,

you guys have been very helpful until now, I hope we can solve this problem together. I would really appreciate it.

I am attaching the file, and basically what i need is:
- starting in column F, to search down the column for cells with text and when it is found, then to be checked if it matches until the next empty one.
In this case it would be to check if cells F12 F13 and F14 match (have the same text), and if they do, then match them if cell in column before (E11) is also the same, and if it is, then delete all...

- and then move down to the next cell with text and do the same. (if F17, F18, F19 match with E16).. then delete

[Bob Phillips]

Public Sub ProcessData()
Dim Lastrow As Long
Dim i As Long
Dim cell As Range

Application.ScreenUpdating = False

With ActiveSheet

Lastrow = .UsedRange.Rows.Count + .UsedRange.Cells(1, 1).Row - 1
For i = Lastrow To 2 Step -1

If .Cells(i, "F").Value2 = .Cells(i - 1, "F").Value2 Then

If .Cells(i, "E").Value2 = .Cells(i - 1, "E").Value2 Then

.Rows(i).Delete
End If
End If
Next i
End With

Application.ScreenUpdating = True
End Sub

[dani9]

It is leaving the first row. It should delete all of the three rows F13 F14 and F15 for example, so the end result would have columns E and F empty.

so I attached the final result, the rows with yellow background should all be deleted.

[Bob Phillips]

Yet again, I am confused. E15/F15 does not equal E14/F14, so why would it be deleted?

[dani9]

Yet again, I am confused. E15/F15 does not equal E14/F14, so why would it be deleted?

if you take a look at the first file I attached, you see that F12:F14 are the same and the match E11, so F12:F14 should all be deleted - all three rows..

In my file, they are all the same, I hope you don't see diferent data.

[Aussiebear]

From my reading of the request, the OP wants "If a found value in a column E matches a value in Column F and if the Value in Column F resides in the row below the value in column E then delete the row that the F value resides in.

Public Sub ProcessData()
Dim Lastrow As Long
Dim i As Long
Dim cell As Range
Application.ScreenUpdating = False
With ActiveSheet
Lastrow = .UsedRange.Rows.Count + .UsedRange.Cells(1, 1).Row - 1
For i = Lastrow To 2 Step -1
If .Cells(i, "E").Value2 = .Cells(i - 1, "F").Value2 Then
.Rows(i).Delete
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Not tested but trying to follow the logic

[dani9]

From my reading of the request, the OP wants "If a found value in a column E matches a value in Column F and if the Value in Column F resides in the row below the value in column E then delete the row that the F value resides in.

Public Sub ProcessData()
Dim Lastrow As Long
Dim i As Long
Dim cell As Range
Application.ScreenUpdating = False
With ActiveSheet
Lastrow = .UsedRange.Rows.Count + .UsedRange.Cells(1, 1).Row - 1
For i = Lastrow To 2 Step -1
If .Cells(i, "E").Value2 = .Cells(i - 1, "F").Value2 Then
.Rows(i).Delete
End If
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Not tested but trying to follow the logic

I tested it, and it deletes only one row. Can we rewrite it, that if the whole range in column F is the same (F12:F14) then delete all 3 rows. If one of them inside this range is different, then DON'T delete them.

This comparison of the E column is just a safety switch, but we can also skip that.

The important thing is that all rows with text are deleted if ALL of them match.

I hope this can be solved, because i'm lost here. I have been dealing with this problem for a while now

[Bob Phillips]

I am sure it can be solved, if we understood what you want. I for one do not understand the rules that determine what is to be deleted.

[dani9]

I am sure it can be solved, if we understood what you want. I for one do not understand the rules that determine what is to be deleted.

First of all, thanks for dealing with me :)
OK, if we start from the beginning... If we open the first file, that i uploaded.. first let us take column F - starting column. If we go down the column, searching for ranges with text.

First range with text is F12:F14 - and here we check if text in all cells (inside this range) are the same, and if True, then delete all 3 rows.

now we move down and we see another range with text: F17:F19, and we see the text inside this range is also the same, so delete all 3 rows.

and apply the same logic for the whole column, and when finished move to the next column - column E.

[dani9]

I am working on something like this:

If Len(ActiveCell) > 2 Then
ActiveCell.Name = "MiniRange"
Do While Len(i) > 2
i = i + 1
Loop
For Each cell In Range("MiniRange")
If cell.Value <> cell.Offset(1, 0).Value Then
Range("MiniRange").Rows.Delete
End If
ElseIf Len(ActiveCell) < 2 Then
ActiveCell.Offset(1, 0).Select
End If
but i have problems with putting it into a correct order, and didn't manage to test it yet

[dani9]

From my reading of the request, the OP wants "If a found value in a column E matches a value in Column F and if the Value in Column F resides in the row below the value in column E then delete the row that the F value resides in.

Public Sub ProcessData()
Dim Lastrow As Long
Dim i As Long
Dim cell As Range
Application.ScreenUpdating = False
With ActiveSheet
Lastrow = .UsedRange.Rows.Count + .UsedRange.Cells(1, 1).Row - 1
For i = Lastrow To 2 Step -1
If .Cells(i, "E").Value2 = .Cells(i - 1, "F").Value2 Then
.Rows(i).Delete
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Not tested but trying to follow the logic
I rearranged your code, but i need help with the IF part... can you check it please?
Public Sub ProcessData()
Dim Lastrow As Long
Dim LastRange As Long
Dim i As Long
Dim y As Long
Dim AllTheSame As Boolean
Dim cell As Range

Application.ScreenUpdating = False
AllTheSame = True

With ActiveSheet

Lastrow = .UsedRange.Rows.Count + .UsedRange.Cells(1, 1).Row - 1
LastRange = IsEmpty(ActiveCell.Offset(1, 0))

For i = Lastrow To 2 Step -1

If .Len(Cells(i, "E").Value) > 2 Then

For y = 1 To LastRange
If Cells(i, "E").Value2 = Cells(i - y, "F").Value2 Then
Next y
If AllTheSame Then
Range(Cells(i - y, "F"), Cells(i - LastRange, "F")).Delete
End If
End If
End If
Next i
End With

Application.ScreenUpdating = True

End Sub

anyone?

[Trebor76]

Hi there,

Try this where, working upwards to Row 1 from the last row found, any row will be deleted (so make sure you initially try it on a copy of your data in case the results are not as expected) if an entry exists (is duplicated) in the row above (expect for Row 1) or below within the same Column:


Sub Macro1()

Dim lngActiveRowNum As Long, _
lngLastRow As Long

'Find the last row from Col's A to F (inclusive).
lngLastRow = Range("A:F").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Application.ScreenUpdating = False
For lngActiveRowNum = lngLastRow To 1 Step -1
If lngActiveRowNum > 1 Then
If Range("A" & lngActiveRowNum).Value = Range("A" & lngActiveRowNum - 1).Value And _
Range("B" & lngActiveRowNum).Value = Range("B" & lngActiveRowNum - 1).Value And _
Range("C" & lngActiveRowNum).Value = Range("C" & lngActiveRowNum - 1).Value And _
Range("D" & lngActiveRowNum).Value = Range("D" & lngActiveRowNum - 1).Value And _
Range("E" & lngActiveRowNum).Value = Range("E" & lngActiveRowNum - 1).Value And _
Range("F" & lngActiveRowNum).Value = Range("F" & lngActiveRowNum - 1).Value Or _
Range("A" & lngActiveRowNum).Value = Range("A" & lngActiveRowNum + 1).Value And _
Range("B" & lngActiveRowNum).Value = Range("B" & lngActiveRowNum + 1).Value And _
Range("C" & lngActiveRowNum).Value = Range("C" & lngActiveRowNum + 1).Value And _
Range("D" & lngActiveRowNum).Value = Range("D" & lngActiveRowNum + 1).Value And _
Range("E" & lngActiveRowNum).Value = Range("E" & lngActiveRowNum + 1).Value And _
Range("F" & lngActiveRowNum).Value = Range("F" & lngActiveRowNum + 1).Value Then
Rows(lngActiveRowNum).Delete
End If
End If
Next lngActiveRowNum

Application.ScreenUpdating = True

End Sub

HTH

Robert

[dani9]

Thank you,, but this is still not checking if ALL cells in ranges are the same, this is basically what Aussiebear wrote, just in different VBA code.

The hack is to check if all Cells in range - for example in range F12:F14 - match each other. If yes, then delete the whole range (rows 12, 13 and 14!), else if there is one different inside this range, then dont delete any rows in this range.

[Trebor76]

OK, let me know how this goes (again on a copy of your data in case the results are not as expected):


Option Explicit
Sub Macro2()

Dim lngLastRow As Long, _
lngColCount As Long
Dim rngCell As Range, _
rngCurrentRange As Range, _
rngDelRange As Range

'Find the last row from Col's A to F (inclusive).
lngLastRow = Range("A:F").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Application.ScreenUpdating = False

For lngColCount = 1 To 6 'Col's A to F

Set rngCurrentRange = Range(Cells(1, lngColCount), Cells(lngLastRow, lngColCount))

For Each rngCell In rngCurrentRange

If rngCell.Row = 1 Then

If Len(rngCell.Value) > 0 And rngCell.Value = rngCell.Offset(1, 0).Value Then
Set rngDelRange = Cells(rngCell.Row, rngCurrentRange.Column)
End If

ElseIf Len(rngCell.Value) > 0 Then

If rngCell.Value = rngCell.Offset(-1, 0).Value Or rngCell.Value = rngCell.Offset(1, 0).Value Then

If rngDelRange Is Nothing Then
Set rngDelRange = Cells(rngCell.Row, rngCurrentRange.Column)
Else
Set rngDelRange = Union(rngDelRange, Cells(rngCell.Row, rngCurrentRange.Column))
End If

End If

End If

Next rngCell

'If the 'rngDelRange' has been set, then...
If Not rngDelRange Is Nothing Then
'...delete the rows within it and clear the range ready for checking the next Column.
rngDelRange.EntireRow.Delete
Set rngDelRange = Nothing
End If

Next lngColCount

Application.ScreenUpdating = True

End Sub

Robert

[dani9]

This basically works, but is it possible to make it start at the last row and go up and from the last column and move to the left?

[Trebor76]

Maybe, but why if my later post works and working up through the rows has proven not to work (this was my initial approach) :confused:

This has taken me too long as it is so I can't spend any more time on it.

Good luck with it all.

[dani9]

Maybe, but why if my later post works and working up through the rows has proven not to work (this was my initial approach) :confused:

This has taken me too long as it is so I can't spend any more time on it.

Good luck with it all.

thanks for your help so far, i will try to work something out with your formula.

The thing is, if we delete column E before column F, then the point gets lost, as if we start from the back, then some deleted rows collapse other rows together and they give us more ranges that match and have to be deleted.

but, thank you again, i really appreciate it!

[shrivallabha]

Maybe this is how you want it to work.
Dim r As Range
Public Sub DeleteMatches()
Dim lLastRow As Long
Call Cleans
For k = 6 To 5 Step -1
lLastRow = Cells(Rows.Count, k).End(xlUp).Row
Set r = Cells(lLastRow, k)
For i = lLastRow To 2 Step -1
If Cells(i - 1, k).Value = Cells(i, k).Value Then
Set r = Union(r, Cells(i - 1, k))
ElseIf Cells(i - 1, k).Value = "" Then
If Cells(i, k - 1).End(xlUp).Value = Cells(i, k).Value Then
r.EntireRow.Delete
Set r = Cells(i, k).End(xlUp)
i = r.Row + 1
End If
End If
Next i
Next k
End Sub
Private Sub Cleans()
Set r = ActiveSheet.UsedRange
For Each cell In r
cell.Value = Trim(cell.Value)
Next cell
End Sub
Your data seems to be full of invisible characters, so it gave me error. To counter this I have added the Cleans subroutine.

At this point, it will check only for columns E & F (and probably works correctly).

I have seen your delete worksheet also (yellowed cells) but Column D seems little confusing so I didn't include it.
Explain: D2: D4 matches with C1 so you want to delete it but the same will also apply to D6 and C5 but you haven't deleted.

[dani9]

I rearranged the data a bit, changed some rows, just to try it on different data and the formula seems to get confused when there is a row with different data inside. I attached a file, and colored the rows in green instead of deleting them. And I only tried it on column F, didn't go to column E..
As you see :
- the F16 is "deleted" - green, but it shouldn´t be, because it doesn't match F15 and E14
- F23 should also be green and deleted, because it is the same as the two rows above it
- F27 is green, but it shouldn't be, because it doesn't match with the two rows above.

I'm working on your formula, but if you are faster, then I would appreciate it if you post the solution again :)

Thanks in advance!

[shrivallabha]

I should admit that I am having a difficulty in phrasing the situation.

In fact, I'd like to have a few things clarified than working on code.
By the look of it, it seems to be Parent-Child tree kind of a thing.
1. Where F Column Data will be deleted on the basis of it matching with E column Parent Data.
2. If the Data doesn't match then don't delete data.

I have highlighted rows to be deleted (manually) for column E & F. If I have understood it correctly then I will try to have a go at it again. Or as dumb it may sound, I need to understand the logic!

[dani9]

I should admit that I am having a difficulty in phrasing the situation.

In fact, I'd like to have a few things clarified than working on code.
By the look of it, it seems to be Parent-Child tree kind of a thing.
1. Where F Column Data will be deleted on the basis of it matching with E column Parent Data.
2. If the Data doesn't match then don't delete data.

I have highlighted rows to be deleted (manually) for column E & F. If I have understood it correctly then I will try to have a go at it again. Or as dumb it may sound, I need to understand the logic!
Yes, you are right, it is a parent child relationship, where all the children have to match the parent to be deleted, otherwise non of the children are to be deleted.

In this case, where you highlighted row 15 and 26, they are NOT to be deleted, because cells under and above don't match each other.

Hope you understand it now.. it also took me a while to understand when this was handed over to me :S

[shrivallabha]

Lets work it out step by step. Check this for column F.
Public Sub DeleteMatches()
Dim lLastRow As Long
Call Cleans
For k = 6 To 6 Step -1
lLastRow = Cells(Rows.Count, k).End(xlUp).Row
For i = lLastRow To 2 Step -1
If (Cells(i + 1, k).Value = Cells(i, k).Value Or Cells(i + 1, k).Value = "") And _
(Cells(i, k).Value = Cells(i - 1, k).Value Or Cells(i - 1, k).Value = "") And _
(Cells(i, k).Value = Cells(i, k - 1).End(xlUp).Value) Then
Rows(i).Delete
End If
Next i
Next k
End Sub


I have edited post; please check edited code!

[dani9]

Lets work it out step by step. Check this for column F.
Public Sub DeleteMatches()
Dim lLastRow As Long
Call Cleans
For k = 6 To 6 Step -1
lLastRow = Cells(Rows.Count, k).End(xlUp).Row
For i = lLastRow To 2 Step -1
If (Cells(i - 1, k).Value = Cells(i, k).Value Or Cells(i - 1, k).Value = "") And _
Cells(i, k - 1).End(xlUp).Value = Cells(i, k).Value Then
Rows(i).Delete
End If
Next i
Next k
End Sub

this seems to work on every other column but F :))
and the Call Cleans seems to block everything.

[shrivallabha]

I had posted only edited code. Sorry for confusion.
Dim r As Range
Public Sub DeleteMatches()
Dim lLastRow As Long
Call Cleans
For k = 6 To 6 Step -1
lLastRow = Cells(Rows.Count, k).End(xlUp).Row
For i = lLastRow To 2 Step -1
If (Cells(i + 1, k).Value = Cells(i, k).Value Or Cells(i + 1, k).Value = "") And _
(Cells(i, k).Value = Cells(i - 1, k).Value Or Cells(i - 1, k).Value = "") And _
(Cells(i, k).Value = Cells(i, k - 1).End(xlUp).Value) Then
Rows(i).Delete
End If
Next i
Next k
End Sub
Private Sub Cleans()
Set r = ActiveSheet.UsedRange
For Each cell In r
cell.Value = Trim(cell.Value)
Next cell
End Sub

[dani9]

I had posted only edited code. Sorry for confusion.
Dim r As Range
Public Sub DeleteMatches()
Dim lLastRow As Long
Call Cleans
For k = 6 To 6 Step -1
lLastRow = Cells(Rows.Count, k).End(xlUp).Row
For i = lLastRow To 2 Step -1
If (Cells(i + 1, k).Value = Cells(i, k).Value Or Cells(i + 1, k).Value = "") And _
(Cells(i, k).Value = Cells(i - 1, k).Value Or Cells(i - 1, k).Value = "") And _
(Cells(i, k).Value = Cells(i, k - 1).End(xlUp).Value) Then
Rows(i).Delete
End If
Next i
Next k
End Sub
Private Sub Cleans()
Set r = ActiveSheet.UsedRange
For Each cell In r
cell.Value = Trim(cell.Value)
Next cell
End Sub

This works perfectly for column F but not for others! I limited it to column F but it still deletes data in other columns... How can I narrow it just to column F?
I tried for k = 6 to 6, but it doesn't work.

[shrivallabha]

It was flawed so it didn't work. I guess, I have figured out a way this time. Test this.
Basis:
Column F is the rightmost and therefore, lowermost in the hierarchy. Deletion criterion (nearly the same as per the previous post with little change)
Then on if Parent has at least one child then don't delete. If it doesn't have a child and if it matches with its parent then delete.

I have maintained it upto column 5 for safety. Test it first.
Dim r As Range
Public Sub DeleteMatches()
Dim lLastRow As Long
Call Cleans
For k = 6 To 5 Step -1 'Reduce the column number from 5 to 4, 3 etc. if it works :)
lLastRow = Cells(Rows.Count, k).End(xlUp).Row
If k = 6 Then
For i = lLastRow To 2 Step -1
'This is working criterion for column 6
If (Cells(i + 1, k).Value = Cells(i, k).Value Or Cells(i + 1, k).Value = "") And _
(Cells(i, k).Value = Cells(i - 1, k).Value Or Cells(i - 1, k).Value = "") And _
(Cells(i, k).Value = Cells(i, k - 1).End(xlUp).Value) And _
(Cells(i, k).Value <> "") Then
Rows(i).Delete
End If
Next i
Else
For i = lLastRow To 2 Step -1
If (Cells(i, k).Value <> "" And Cells(i, k).Offset(1, 1).Value = "") And _
Cells(i, k).Value = Cells(i, k - 1).End(xlUp).Value Then
Rows(i).Delete
End If
Next i
End If
Next k
End Sub
Private Sub Cleans()
Set r = ActiveSheet.UsedRange
For Each cell In r
cell.Value = Trim(cell.Value)
Next cell
End Sub

[dani9]

In the meanwhile I have found kind of a temporary solution, which works, so I will keep it. It was really hard to explain my needs, and therefore I would really like to thank everyone who kept up with me! Again, thank you all very much!

this is my solution, in case anyone will need it in the future.

Option Explicit
Sub Macro_Test2()

Dim lngLastRow As Long, _
lngColCount As Long, _
i As Long, _
y As Long
Dim rngCell As Range, _
rngCurrentRange As Range, _
rngDelRange As Range, _
LastRow As Long, _
RngCellOff As Range

'Find the last row from Col's A to F (inclusive).
lngLastRow = Range("A:F").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Application.ScreenUpdating = False

For lngColCount = 4 To 4 'Col's A to F

Set rngCurrentRange = Range(Cells(1, lngColCount), Cells(lngLastRow, lngColCount))

'For Each rngCell In rngCurrentRange
For i = 2 To lngLastRow
Set rngCell = Cells(i, lngColCount)

If rngCell.Row = 2 Then ' if row number is 2
If Len(rngCell.Value) > 0 And rngCell.Value = rngCell.Offset(1, 0).Value And _
rngCell.Offset(1, 1).Value = rngCell.Offset(2, 1).Value Then
Set rngDelRange = Cells(rngCell.Row, rngCurrentRange.Column)
End If
End If

If rngCell.Row > 2 Then ' if row number is more than 2

If Len(rngCell.Value) > 2 Then

' first cell different than second, skip rows with text
If Len(rngCell.Offset(-1, 0).Value) < 2 And Len(rngCell.Offset(1, 0).Value) > 2 Then
If rngCell.Value <> rngCell.Offset(1, 0).Value Then
y = 0
Do While Len(rngCell.Offset(y, 0).Value2) >= 2
y = y + 1
Loop
Set rngCell = rngCell.Offset(y, 0)
i = rngCell.Row
End If
End If


' first cell different than third, skip rows with text
If Len(rngCell.Offset(-1, 0).Value) < 2 And _
Len(rngCell.Offset(1, 0).Value) > 2 And _
Len(rngCell.Offset(2, 0).Value) > 2 Then
If rngCell.Value <> rngCell.Offset(2, 0).Value Then
y = 0
Do While Len(rngCell.Offset(y, 0).Value2) >= 2
y = y + 1
Loop
Set rngCell = rngCell.Offset(y, 0)
i = rngCell.Row
End If
End If

' first cell different than fourth, skip rows with text
If Len(rngCell.Offset(-1, 0).Value) < 2 And _
Len(rngCell.Offset(1, 0).Value) > 2 And _
Len(rngCell.Offset(2, 0).Value) > 2 And _
Len(rngCell.Offset(3, 0).Value) > 2 Then
If rngCell.Value <> rngCell.Offset(3, 0).Value Then
y = 0
Do While Len(rngCell.Offset(y, 0).Value2) >= 2
y = y + 1
Loop
Set rngCell = rngCell.Offset(y, 0)
i = rngCell.Row
End If
End If

' first cell different than fifth, skip rows with text
If Len(rngCell.Offset(-1, 0).Value) < 2 And _
Len(rngCell.Offset(1, 0).Value) > 2 And _
Len(rngCell.Offset(2, 0).Value) > 2 And _
Len(rngCell.Offset(3, 0).Value) > 2 And _
Len(rngCell.Offset(4, 0).Value) > 2 Then
If rngCell.Value <> rngCell.Offset(4, 0).Value Then
y = 0
Do While Len(rngCell.Offset(y, 0).Value2) >= 2
y = y + 1
Loop
Set rngCell = rngCell.Offset(y, 0)
i = rngCell.Row
End If
End If

' first cell different than sixth, skip rows with text
If Len(rngCell.Offset(-1, 0).Value) < 2 And _
Len(rngCell.Offset(1, 0).Value) > 2 And _
Len(rngCell.Offset(2, 0).Value) > 2 And _
Len(rngCell.Offset(3, 0).Value) > 2 And _
Len(rngCell.Offset(4, 0).Value) > 2 And _
Len(rngCell.Offset(5, 0).Value) > 2 Then
If rngCell.Value <> rngCell.Offset(5, 0).Value Then
y = 0
Do While Len(rngCell.Offset(y, 0).Value2) >= 2
y = y + 1
Loop
Set rngCell = rngCell.Offset(y, 0)
i = rngCell.Row
End If
End If

If Len(rngCell.Offset(-1, 0).Value) < 2 And Len(rngCell.Offset(1, 0).Value) < 2 And _
Len(rngCell.Offset(1, 1).Value) < 2 Then ' only one cell with text
y = 0
Do While Len(rngCell.Offset(y, -1).Value2) < 2
y = y - 1
Loop
Set RngCellOff = rngCell.Offset(y, -1)
If rngCell.Value = RngCellOff.Value Then
If rngDelRange Is Nothing Then
Set rngDelRange = Cells(rngCell.Row, rngCurrentRange.Column)
Else
Set rngDelRange = Union(rngDelRange, Cells(rngCell.Row, rngCurrentRange.Column))
End If
End If
End If

If rngCell.Value = rngCell.Offset(-1, 0).Value And Len(rngCell.Offset(-1, 0).Value) > 2 And _
rngCell.Offset(1, 1).Value = rngCell.Offset(0, 1).Value Or _
rngCell.Value = rngCell.Offset(1, 0).Value And Len(rngCell.Offset(1, 0).Value) > 2 And _
rngCell.Offset(1, 1).Value = rngCell.Offset(2, 1).Value Then ' if one cell up or one cell down is the same, include in range

If rngDelRange Is Nothing Then
Set rngDelRange = Cells(rngCell.Row, rngCurrentRange.Column)
Else
Set rngDelRange = Union(rngDelRange, Cells(rngCell.Row, rngCurrentRange.Column))
End If
End If

If lngColCount <= 13 Then
If rngCell.Value = rngCell.Offset(-1, -1).Value And _
Len(rngCell.Offset(1, 1).Value) < 2 And Len(rngCell.Offset(-1, -1).Value) > 2 Then

If rngDelRange Is Nothing Then
Set rngDelRange = Cells(rngCell.Row, rngCurrentRange.Column)
Else
Set rngDelRange = Union(rngDelRange, Cells(rngCell.Row, rngCurrentRange.Column))
End If
End If
End If
End If
End If
Next i

'If the 'rngDelRange' has been set, then...
If Not rngDelRange Is Nothing Then
'...delete the rows within it and clear the range ready for checking the next Column.

rngDelRange.EntireRow.Delete
Set rngDelRange = Nothing
End If
Next lngColCount
Application.ScreenUpdating = True
End Sub


Thanks to all!