Help with Marco - how do I find and delete the whole row if value exists in both columns

[crag8119]

Hi,

In Columns O & P I have values like below:

0	R1177092
0	R1177093
0	R1177227
R1178634	R1178511
0	R1178185
0	R1178634
R1179555	0

<colgroup><col><col></colgroup><tbody>
</tbody>

I need a Marco to find and delete the whole row , if the same values exists in both columns.

For example: R1178634 exists in column O and on a different row column P. I want to delete the whole rows.

Delete row 4 in Columns O
and Delete row 6 in Columns P as value R1178634 exists in both columns.

Thanks

 

[Yongle]

These are the assumptions I have made

1. IF R12345 is in O27 and FIRST matched R12345 is in P5 then delete rows 5 and 27 (do not look for any other matches)
- this means that a maximum of 2 rows are deleted each time (only one row would be deleted if matched value is in same row as the one being tested)
- effectively deleting "matched pairs of values"

2. Ignore balnk cells in column O when trying to find a match

3. Ignore cells = 0 (zero) in column O when trying to find a match


Test in a COPY of your workbook!

Option Explicit
Sub DeleteRows()
    Dim c1  As Range, c2 As Range, rng As Range, r As Long
    Dim rC      As Long:        rC = Rows.Count
    Dim nextR   As Long:        nextR = 2                               [COLOR=#006400][I]'first row with values[/I][/COLOR]
With ActiveSheet
Recurse:
    r = WorksheetFunction.Max(.Range("O" & rC).End(xlUp).Row, .Range("P" & rC).End(xlUp).Row)
    Set rng = .Range("O" & nextR, .Range("O" & [COLOR=#ff0000]r[/COLOR]))                      [I][COLOR=#006400]'[/COLOR][COLOR=#ff0000]r[/COLOR][COLOR=#006400] decreases as rows are deleted[/COLOR][/I]
    For Each c1 In rng
        If c1 <> "" And c1 <> 0 Then
            On Error Resume Next                                        [I][COLOR=#006400]'find a matching value[/COLOR][/I]
                Set c2 = rng.Offset(, 1).Find(c1, LookIn:=xlValues, lookat:=xlWhole)
            On Error GoTo 0
                If Not c2 Is Nothing Then
                    If c2.Row < c1.Row Then nextR = c1.Row - 1         [COLOR=#006400][I] 'is a row above c1 about to be deleted?[/I][/COLOR]
                    If c2.Row = c1.Row Then r = r - 1 Else r = r - 2    '[I][COLOR=#006400]how many rows are being deleted[/COLOR][/I]
                    Union(c1, c2).EntireRow.Delete                     [COLOR=#006400][I] 'delete row(s)[/I][/COLOR]
                    Set c2 = Nothing
                    GoTo Recurse
                End If
        End If
    Next c1
End With

End Sub

BEWARE
Please note that I made a couple of minor adjustments to code after first posting!!

 

[crag8119]

These are the assumptions I have made

1. IF R12345 is in O27 and FIRST matched R12345 is in P5 then delete rows 5 and 27 (do not look for any other matches)
- this means that a maximum of 2 rows are deleted each time (only one row would be deleted if matched value is in same row as the one being tested)
- effectively deleting "matched pairs of values"

2. Ignore balnk cells in column O when trying to find a match

3. Ignore cells = 0 (zero) in column O when trying to find a match


Test in a COPY of your workbook!

Option Explicit
Sub DeleteRows()
    Dim c1  As Range, c2 As Range, rng As Range, r As Long
    Dim rC      As Long:        rC = Rows.Count
    Dim nextR   As Long:        nextR = 2                               [COLOR=#006400][I]'first row with values[/I][/COLOR]
With ActiveSheet
Recurse:
    r = WorksheetFunction.Max(.Range("O" & rC).End(xlUp).Row, .Range("P" & rC).End(xlUp).Row)
    Set rng = .Range("O" & nextR, .Range("O" & [COLOR=#ff0000]r[/COLOR]))                      [I][COLOR=#006400]'[/COLOR][COLOR=#ff0000]r[/COLOR][COLOR=#006400] decreases as rows are deleted[/COLOR][/I]
    For Each c1 In rng
        If c1 <> "" And c1 <> 0 Then
            On Error Resume Next                                        [I][COLOR=#006400]'find a matching value[/COLOR][/I]
                Set c2 = rng.Offset(, 1).Find(c1, LookIn:=xlValues, lookat:=xlWhole)
            On Error GoTo 0
                If Not c2 Is Nothing Then
                    If c2.Row < c1.Row Then nextR = c1.Row - 1         [COLOR=#006400][I] 'is a row above c1 about to be deleted?[/I][/COLOR]
                    If c2.Row = c1.Row Then r = r - 1 Else r = r - 2    '[I][COLOR=#006400]how many rows are being deleted[/COLOR][/I]
                    Union(c1, c2).EntireRow.Delete                     [COLOR=#006400][I] 'delete row(s)[/I][/COLOR]
                    Set c2 = Nothing
                    GoTo Recurse
                End If
        End If
    Next c1
End With

End Sub

BEWARE
Please note that I made a couple of minor adjustments to code after first posting!!

Great thank you,

If I want to delete rows from A:P if it finds matches in O-P, do I just adjust the max range?

 

[Yongle]

Have you tested the code?

 

[crag8119]

Yes, thank you. However how do I get it to delete the whole rows data not just O & P rows? I need it to delete A-P if possible ?

Thank you again

 

[Yongle]

Running the code does that for me
What exactly is the code doing when you run it?

 

[crag8119]

No, its me it works fine. Just annoy my last post.

 

[crag8119]

Hi Yongle,

Where in the code can I add the range O30:P6000? I only want it to look for matches in that range and delete.

Thank you

 

[Yongle]

To begin at row 30

Replace

nextR = 2

With

nextR = 30

Is there anything below row 6000 or is 6000 simply a big enough number to always include your range?

 

[crag8119]

To begin at row 30

Replace

nextR = 2

With

nextR = 30

Is there anything below row 6000 or is 6000 simply a big enough number to always include your range?

6000 , as nothing below that. At the moment I have to keep running the code as it deletes 2-or three matches at a time. No a big problem to be honest, however is there any way to loop it to keep running until there are no matches in column O and P?

Thank you for your time and code it's a massive help and I am learning