Delete Duplicate Cells - Excel

[Monkeygumbo]

hi all,

I need to write a macro that finds all the cells in the first column that have duplicate names. Then it must delete all the rows that it finds.

What's the easiest way to start?

MG

 

[Loomah]

hi
assuming what you want is to be left with a unique list you could use filter

choose DATA>FILTER>ADVANCED FILTER
select the 'unique records only' option and have your new listput on a different (clean) sheet. click ok!

then delete the other sheet.

happy friday
bring on the robins
;-) If a man says something and there are no women there to hear him, is he still wrong?

 

[Monkeygumbo]

Will that delete both duplicates?

 

[Loomah]

?

If you have a list a,a,b,b,b,c,c,c,d,e,e,e,e,e and filter as above to another location you will have a list of 'uniques' but you will also still have your original.
So now you've got
a,a,b,b,b,c,c,c,d,e,e,e,e,e
and
a,b,c,d,e

Nothing is deleted so far. If the second list is what you want to be left with, then get rid of the original all together.

If this isn't what you wan to achieve, just ignore me!!

happy friday
23 hours to go
;-) If a man says something and there are no women there to hear him, is he still wrong?

 

[Monkeygumbo]

I see, that filter selects distinct rows. I'm looking for:
a,a,a,a,a,b,c,c,d,d,d,e,f
(Run macro)
returns:
b,e,f

The logic is simple, but I don't remember the syntax for VBA in Excel.

Thanks
MG

 

[Loomah]

Hi
As an aside is there anything in thread707-336358 that relates to what you're doing??

Either way, here's something I just made up. It ain't pretty and probably won't be quick over 1000s of rows (I tested on 21 rows!!) I'm sure I've seen something better posted some time ago (acron or skip, probably)

This will turn a,a,b,c,c,d,e,e,f into b,d,f. It (kinda) relies on there being no gaps in your data, the data begining at A1 and the column you want to fid duplicates in needs to be the first column. These can be adapted.


Anyway...

Sub ClearDuplicatedRows()
' clear all rows that appear more than once
' this does not leave a list of unique values
' leaves list of single occurences
Dim c As Range
Dim bTest As Boolean
Dim lRow As Long
Dim lCount As Long

bTest = False

With Range("A1")
    .Select
    lRow = .CurrentRegion.Rows.Count
End With
    ' will only work if data is sorted
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

For lCount = 1 To lRow
    If IsEmpty(Cells(lCount, 1)) Then Exit Sub
    
    If bTest = True Then
        Cells(lCount - 1, 1).EntireRow.Delete
        If lCount > 1 Then lCount = lCount - 1
        bTest = False
    End If
    
    Do
    Set c = Cells(lCount, 1)
        If Not IsEmpty(c.Offset(1, 0)) And c.Offset(1, 0).Value = c.Value Then
            bTest = True
            c.Offset(1, 0).EntireRow.Delete
        Else: Exit Do
        End If
    Loop

Next
End Sub

hope this fits the bill

;-)
off to a flyer, bring on m@n ure!!
If a man says something and there are no women there to hear him, is he still wrong?

 

[dwilson01]

I posted this on another thread and it seemed to work well for gramaw, give it a try. You will have to enter a 1, to select the first column, in the dialog box when you run this code.

Sub DelDups()

Dim jRange As Range, Col As Integer, rowLast As Integer

'Application.ScreenUpdating = False
ActiveSheet.UsedRange
Col = InputBox("Enter Column Number", "Column Selector")
i = 1: k = 0
ActiveSheet.Columns(Col).Select
rowLast = Selection.CurrentRegion.Rows.Count
Range(Cells(1, Col), Cells(rowLast, Col)).Select
With Selection
    Do
      strTemp = ActiveSheet.Cells(i, Col)
      'If IsEmpty(strTemp) Then GoTo exitloop
      Set c = .Find(strTemp)
      If Not c Is Nothing Then
        firstaddress = c.Address
        Do
          Set c = .FindNext(c)
          If k = 1 Or firstaddress <> c.Address Then
           Range(firstaddress).EntireRow.Select
           Selection.Delete Shift:=xlUp
           rowLast = rowLast - 1
           If .Find(strTemp) Is Nothing Then i = i - 1: GoTo exitloop
           firstaddress = c.Address
           k = 1
          End If
        Loop While Not c Is Nothing And k = 1 Or firstaddress <> c.Address
      End If
exitloop:
      i = i + 1
      k = 0
    Loop Until i > rowLast
End With

'Application.ScreenUpdating = True
End Sub

Let me know if it works for you

Dave