Delete rows based on unique values

JohnPoole

Active Member
Joined
Jun 9, 2005
Messages
267
Hi all, I was looking at an old thread from 2017:
,
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

VBA Code:
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:
VBA 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,.
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
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?
 
Upvote 0
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.
 
Upvote 0
Please try the following on a copy of your workbook.
VBA Code:
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
 
Upvote 0
Hmm, is their any easy way to report the rows identified and the value in A1 before it get's deleted? Thanks.
 
Upvote 0
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?
 
Upvote 0

Forum statistics

Threads
1,224,819
Messages
6,181,153
Members
453,021
Latest member
Justyna P

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top