Delete Cells with Matching Numbers

[Guzzlr]

Hello All.

Sub Delete_Matching_Numbers()
    Dim lastRow As Long
    
    [COLOR=#336600]' Application.ScreenUpdating = False[/COLOR]
    
[COLOR=#336600]'Find last row in column B[/COLOR] 
    lastRow = Cells(Rows.Count, "B").End(xlUp).Row

[COLOR=#336633]'Run Program [/COLOR]
If Range("B8") = Range("C8") Then
    Rows.Range("B8:C8").Delete
[COLOR=#000000]End If[/COLOR][COLOR=#336600]
    ' Application.ScreenUpdating = True[/COLOR]
        
End Sub

What I’m trying to accomplish is to have a template, where two columns with numbers. If any two numbers match between the two columns, they will be deleted to find any newly added numbers.

• The code is where I’m beginning. It works if the two numbers in B8:C8 match.
• Where I need help, is the range of columns B & C should go to row 500.
• If any two numbers match on B & C, then the corresponding cells will be deleted.

Example:
B3 = 547
C62 = 547
The program should delete Cells B3 & C62 because the two numbers match.

Thanks for the help

 

[steve the fish]

You could try this. This clears the cells. You could delete them and shift up if you want.

Dim lr As Long, myRow as Variant, c As Range

lr = Cells(Rows.Count, "B").End(xlUp).Row

For Each c In Range("B1:B" & lr)
    myRow = Application.Match(c.Value, Range("C1:C" & lr), 0)
    If Not IsError(myRow) Then
        Range("C" & myRow).ClearContents
        c.ClearContents
    End If
Next

Heres deleting example:

Dim lr As Long, i As Long, myRow As Variant

lr = Cells(Rows.Count, "B").End(xlUp).Row

For i = lr To 1 Step -1
    myRow = Application.Match(Range("B" & i).Value, Range("C1:C" & lr), 0)
    If Not IsError(myRow) Then
        Range("C" & myRow).Delete Shift:=xlUp
        Range("B" & i).Delete Shift:=xlUp
    End If
Next

 

[MickG]

Another option :-
NB:- this code will alter columns "B & C"

[COLOR="Navy"]Sub[/COLOR] MG20Nov05
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] cMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] RngB [COLOR="Navy"]As[/COLOR] Range, RngC [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] cc [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] RngB = Range("B1", Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] RngC = Range("C1", Range("C" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] Rng = Union(RngB, RngC)
oMax = Application.Max(RngB.Count, RngC.Count)
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Value, Dn
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
ReDim Ray(1 To oMax, 1 To 2)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    [COLOR="Navy"]If[/COLOR] .Item(K).Count = 1 [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] .Item(K).Column = 2 [COLOR="Navy"]Then[/COLOR]
            c = c + 1
            Ray(c, 1) = K
        [COLOR="Navy"]ElseIf[/COLOR] .Item(K).Column = 3 [COLOR="Navy"]Then[/COLOR]
            cc = cc + 1
            Ray(cc, 2) = K
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
cMax = Application.Max(cc, c)
[COLOR="Navy"]Next[/COLOR] K
Range("B:C").ClearContents
Range("B1").Resize(cMax, 2) = Ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Guzzlr]

Steve the Fish code is working, except for some reason, the cleared cells are not shifting up?
Thanks

 

[Guzzlr]

Sub Delete_Matching_Numbers()
    Dim lr As Long
    Dim myRow As Variant
    Dim i As Long
    Dim c As Range
    
     Application.ScreenUpdating = True

'*************** Run Program ********************************
lr = Cells(Rows.Count, "B").End(xlUp).Row
For Each c In Range("B1:B" & lr)
    myRow = Application.Match(c.Value, Range("C1:C" & lr), 0)
    If Not IsError(myRow) Then
        Range("C" & myRow).ClearContents
        c.ClearContents
    End If
Next
lr = Cells(Rows.Count, "B").End(xlUp).Row
For i = lr To 1 Step -1
    myRow = Application.Match(Range("B" & i).Value, Range("C1:C" & lr), 0)
    If Not IsError(myRow) Then
        Range("B" & i).Delete Shift:=xlUp
        Range("C" & myRow).Delete Shift:=xlUp
    End If
Next
'    ' Application.ScreenUpdating = True
        
End Sub

Here is your code that I used, did I make a mistake? It looks OK.
Thanks

 

[steve the fish]

You use one or the other of the macros I posted not both together. That's why they were separate.

 

[Guzzlr]

You use one or the other of the macros I posted not both together. That's why they were separate.

Oh...

 

[Guzzlr]

It's Working!