unique entries code

[scrabtree]

I tried the following code several times and it didn't
work???


Sub GetUnique()
Dim rng as Range, rng1 as Range
with Worksheets("Sheet2")
set rng = .Range("A1:A1000")
rng.Formula = "=row()"
rng.Formula = rng.Value
rng.offset(0,1).Formula = "=If(countif(Sheet1!A1:Z100,A1)

0,"""",na())"

On error Resume Next
set rng1 = rng.offset(0,1).SpecialCells
(xlFormulas,xlErrors)
On Error goto 0
if not rng1 is nothing then
rng1.EntireRow.Delete
End if
.Columns(2).Delete
End With
End Sub

--
Regards,
Tom Ogilvy



message

 

[scrabtree]

This code (from the J-Walk site) does almost what I want
but adds the unique entries to a list box. If I could get
the unique entries in Sheet2 Column A:A I would be cooking:
Option Explicit
' This example is based on a tip by J.G. Hussey,
' published in "Visual Basic Programmer's Journal"

Sub RemoveDuplicates()
Dim AllCells As Range, Cell As Range
Dim NoDupes As New Collection
Dim i As Integer, j As Integer
Dim Swap1, Swap2, Item

' The items are in A1:A105
Set AllCells = Range("A1:B105")

' The next statement ignores the error caused
' by attempting to add a duplicate key to the collection.
' The duplicate is not added - which is just what we
want!
On Error Resume Next
For Each Cell In AllCells
NoDupes.Add Cell.Value, CStr(Cell.Value)
' Note: the 2nd argument (key) for the Add method
must be a string
Next Cell

' Resume normal error handling
On Error GoTo 0

' Sort the collection (optional)
For i = 1 To NoDupes.Count - 1
For j = i + 1 To NoDupes.Count
If NoDupes(i) > NoDupes(j) Then
Swap1 = NoDupes(i)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1
End If
Next j
Next i

' Add the sorted, non-duplicated items to a ListBox
For Each Item In NoDupes
UserForm1.ListBox1.AddItem Item
Next Item

' Show the UserForm
UserForm1.Show
End Sub

 

[scrabtree]

I just saw the post in my earlier string, thanks.

-----Original Message-----
I tried the following code several times and it didn't
work???


Sub GetUnique()
Dim rng as Range, rng1 as Range
with Worksheets("Sheet2")
set rng = .Range("A1:A1000")
rng.Formula = "=row()"
rng.Formula = rng.Value
rng.offset(0,1).Formula = "=If(countif(Sheet1!A1:Z100,A1)
On error Resume Next
set rng1 = rng.offset(0,1).SpecialCells
(xlFormulas,xlErrors)
On Error goto 0
if not rng1 is nothing then
rng1.EntireRow.Delete
End if
.Columns(2).Delete
End With
End Sub

--
Regards,
Tom Ogilvy





.

 

[Tom Ogilvy]

I provided a slight revision of my original code, which works for me based
on your description.

 

[scrabtree]

As always, thanks for your help. I'm not sure I
understand how it works, but I see that changing A1:A1000
to A1:A500, changes the upper value it searches for. I
can also change the table range to any option I want.
This will work great.