find and remove... a repeating list

[tourless]

Hi Folks,

I'm copying a variable range of data which may or may not contain a repeating list of values in column A. In the case there IS a repeating list, I would like to keep only the first 'set' and delete all rows below. Turning this...

Prod1
Prod2
Prod3
Prod4
Prod5
Prod1
Prod2
Prod3
Prod4
Prod5
Prod1
Prod2
Prod3
Prod4
Prod5

into this...
Prod1
Prod2
Prod3
Prod4
Prod5

I think it could be as simple as holding the first instance of the first value (which will be in A2 due to header row), and looking for the second instance of that value and deleting it and everything below it. I need to add this functionality to a macro routine.

 

[Fluff]

How about

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

 

[Logit]

.

Option Explicit


Sub DupDel()


Columns("A:A").Select
ActiveSheet.Range("$A:$B").RemoveDuplicates Columns:=1, Header:=xlYes


'Uncomment next line and include RemoveBlankCells macro to delete all blank cells only in Col A
RemoveBlankCells


End Sub


Sub RemoveBlankCells()
'PURPOSE: Deletes single cells that are blank located inside a designated range
'SOURCE: www.TheSpreadsheetGuru.com


Dim rng As Range


'Store blank cells inside a variable
  On Error GoTo NoBlanksFound
    Set rng = Range("A:A").SpecialCells(xlCellTypeBlanks)
  On Error GoTo 0


'Delete blank cells and shift upward
  rng.Rows.Delete Shift:=xlShiftUp


Exit Sub


'ERROR HANLDER
NoBlanksFound:
    MsgBox "No Blank cells were found"


End Sub

 

[tourless]

Perfect, thank you... to you both!

 

[Fluff]

Glad we could help & thanks for the feedback

 

[Logit]

You are welcome.