Delete rows based on unique values

[JohnPoole]

Hi all, I was looking at an old thread from 2017:

vba Delete row if value doesn't exist in a range

I have 2 worksheets (Sheet1 and sheet2). I am trying to write a macro that will look for the cell value of Sheet1 A2 in sheet2 column C. If that value doesn't exist in sheet2 column c then delete row 2 on sheet1. This needs to happen for all rows on sheet1. The amount of rows on sheet1 and...

www.mrexcel.com

,
This provided some code which seemed to work fine, I amended slightly so that it compares Column A in Sheet1 with Column A in Sheet2. If the value in Sheet1 is is unique and doesn't exist in Sheet2, then delete the row from Sheet1

Sub DelRows()

   Dim Cl As Range
   Dim Rng As Range
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Sheets("Sheet2").Range("A2", Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then .Add Cl.Value, Cl.Offset(, 1).Value
      Next Cl
      For Each Cl In Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then
            If Rng Is Nothing Then
               Set Rng = Cl
            Else
               Set Rng = Union(Rng, Cl)
            End If
         End If
      Next Cl
   End With
   'Rng.EntireRow.Delete
End Sub

This all seemed to work fine.... i added some other bits to output the values it was going to delete to the debug window etc and all was working well.... even on lists a couple of thousand rows long.

Until it stopped for no reason that I can see with error 9 - subscript out of Range on line 'For Each Cl In Sheets("Sheet2").Range("A2", Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp))' - and also caused the original un-modified code to break on longer lists also.

My modified code:

Sub DelRowsV1()

   Dim Cl As Range
   Dim Rng As Range
   Dim MyAddress As Variant
   
      
   
   With CreateObject("scripting.dictionary")
   
      For Each Cl In Sheets("Sheet2").Range("C2", Sheets("Sheet2").Range("C" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then .Add Cl.Value, Cl.Offset(, 1).Value
      Next Cl
      
      
      
      
      For Each Cl In Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp))
        
         If Not .exists(Cl.Value) Then
            If Rng Is Nothing Then
               'Debug.Print C1
               Set Rng = Cl
            Else
               'Debug.Print C1
               Set Rng = Union(Rng, Cl)
               'Debug.Print Rng.Address
               MyAddress = Rng.Address
               'Debug.Print MyAddress
            End If
         End If
      Next Cl
   End With
   
  
   
    Dim arr() As String
    Dim MyCell As Range
    ' Split the string to an array
    
    MyAddress = Replace(MyAddress, ":", ",", 1, , vbTextCompare)
    arr = Split(MyAddress, ",")

    
    Dim name As Variant
    For Each name In arr
        Debug.Print "Sheet1!" & name
        'TXT2RNG ("Sheet1!" & name)
        
        Debug.Print "B " & Sheet1.Range(name).Value
    Next
   

   'Rng.EntireRow.Delete
End Sub

I don't understand why my modified code that was working now errors


I think it has something to do with the create object but not sure....

Can anybody explain why this works intermittently or is their a newer / better solution to identify unique entries and report them?

Thanks in advance,.

 

[kevin9999]

Is it the case that you simply want to delete any rows where the value in column A in sheet1 is not found in either column A or C in sheet2? Or does the value in column A on sheet1 also have to be unique? In other words, if the column A (sheet1) value doesn't exists in columns A or C on sheet2 but is not unique (i.e. more than 1 instance in sheet1) then that row is kept?

 

[JohnPoole]

Yes, just report and delete from Sheet 1, if it only exists in Sheet 1. There won't be any duplicates on fhe same sheet.Thanks.

 

[kevin9999]

Please try the following on a copy of your workbook.

Option Explicit
Sub Delete_Not_Found()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")          '<-- *** Change sheet names to suit ***
    Set ws2 = Worksheets("Sheet2")
    Dim d As Object, arr1, arr2, i As Long, key
    Set d = CreateObject("scripting.dictionary")
    arr1 = ws2.Range("A2", ws2.Cells(Rows.Count, "A").End(xlUp))
    arr2 = ws2.Range("C2", ws2.Cells(Rows.Count, "C").End(xlUp))
    For i = 1 To UBound(arr1, 1)
        d(arr1(i, 1)) = 1
    Next i
    For i = 1 To UBound(arr2, 1)
        d(arr2(i, 1)) = 1
    Next i

    Dim a, b, LRow As Long, LCol As Long
    a = ws1.Range("A2", ws1.Cells(Rows.Count, "A").End(xlUp))
    ReDim b(1 To UBound(a, 1), 1 To 1)
    LRow = ws1.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    LCol = ws1.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
    
    For i = 1 To UBound(a, 1)
        If Not d.exists(a(i, 1)) Then b(i, 1) = 1
    Next i
    ws1.Cells(2, LCol).Resize(UBound(b, 1)) = b
    i = WorksheetFunction.Sum(ws1.Columns(LCol))
    
    If i > 0 Then
        ws1.Range(ws1.Cells(2, 1), ws1.Cells(LRow, LCol)).Sort Key1:=ws1.Cells(2, LCol), _
        order1:=xlAscending, Header:=xlNo
        ws1.Cells(2, LCol).Resize(i).EntireRow.Delete
    End If
End Sub

 

[JohnPoole]

Thankyou kevin9999. Tested and works perfectly. Much appreciated.

Thanks,

​

 

[kevin9999]

Happy to help, and thanks for the feedback

 

[JohnPoole]

Hmm, is their any easy way to report the rows identified and the value in A1 before it get's deleted? Thanks.

 

[kevin9999]

Hmm, is their any easy way to report the rows identified and the value in A1 before it get's deleted? Thanks.

How do you want to "report the rows"?

 

[JohnPoole]

I guess the best way would be to stick them in sheet 3 thanks.

 

[kevin9999]

OK John, I'll look at it tomorrow. BTW, what do you mean by the value in A1? The code as it is starts from row 2. A1 in which sheet?