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,.

 

[JohnPoole]

Apologies, yes A2 to whichever is the last row found.

 

[kevin9999]

Hi John, please try the following on a copy of your workbook.

Option Explicit
Sub Delete_Not_Found_V2()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Set ws1 = Worksheets("Sheet1")          '<-- *** Change sheet names to suit ***
    Set ws2 = Worksheets("Sheet2")
    Set ws3 = Worksheets("Sheet3")
    Dim d As Object, arr1, arr2, i As Long
    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.Range("A2").Resize(i, 1).Copy ws3.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        ws1.Cells(2, LCol).Resize(i).EntireRow.Delete
    End If
End Sub

 

[JohnPoole]

Apologies for the delay in responding! I've tested this and it works exactly as requested. Much appreciated for your help with this kevin9999. This will save me a lot of time!

Regards,

John

 

[kevin9999]

Glad we got there John. Cheers

 

[JohnPoole]

Right, just an update, but I've found an odd bug which I can't explain. Using your code like this:

Option Explicit
Sub Delete_Not_Found_from_Broker()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Set ws1 = Worksheets("Sheet1")          '<-- *** Change sheet names to suit ***
    Set ws2 = Worksheets("Sheet2")
    Set ws3 = Worksheets("Sheet3")
    Dim d As Object, arr1, arr2, i As Long
    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.Range("A2").Resize(i, 1).Copy ws3.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        ws1.Cells(2, LCol).Resize(i).EntireRow.Delete
    End If
End Sub

Against a small list works absolutely fine, including a test list which contains the same value (120) in Sheet1.Column(A)

BUT:

If I run it against my target list of 1600 rows, it deletes and reports every case except 1:

And this does not exist in Sheet2.Column(A):

All other cases are correctly identified and output to Sheet3.Column(A): including other numeric and non-numeric results

I thought maybe it could be some odd data issue, so, I've tried keying 120 manually into that field to see if it gets picked up - it doesn't.
I then tried moving that row further down the sheet (from 28 to 37) - It still wont pick up that single value..
As a final test, I've just replaced the 120 with xxx (Not in Sheet2)

And XXX it is correctly picked up and output to Sheet3. Changing back to 120 causes it fail again.

I'm out of ideas why the value 120 is being treated differently in a long list vs a short list.... Sort of the same issue I was originally seeing with the scripting.dictionary object where it was fine for small lists but fell over on longer lists - may be unrelated but thought I'd mention it.

 

[kevin9999]

Strange, and no obvious explanation for this anomaly John. I'd really need to see the actual file to figure it out. Could you share it via Google Drive, Dropbox or similar file sharing platform?

 

[JohnPoole]

I've managed to fix it - the actual target spreadsheet has 10 columns or so in it. If I delete the data in columns C-J that row is then picked up. I'm not sure why that what was causing the problem because their is no data in those columns for that row - but removing them has fixed it so I'll call that fixed! Thanks for your help and patience on this kevin9999.

Regards,

John

 

[kevin9999]

Glad you got it working John.
Cheers
Kev