Unique data...!

[Thyag]

Hi,

I wanted to extract the unique data from a column of around 10000
lines data into a new column or sheet.

Could some one help on this.


Thanks
Thyag

 

[Bob Phillips]

Look at Data>Filter>Advanced Filter

It has a unique option, and can copy elsewhere.

--
---
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Guest]

Here is some code. It will create a new worksheet listing all of the unique
items...

Public Sub GetUniqueItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Object 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed

Application.ScreenUpdating = False
'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)
If rngToSearch Is Nothing Then Set rngToSearch = ActiveCell

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = CreateObject("Scripting.Dictionary")

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) And cell.Value <> Empty Then
'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
End If
Next

If Not dic Is Nothing Then 'Check for dictionary
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For Each dicItem In dic.Items 'Loop through dictionary
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = dicItem 'Add items to new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next dicItem
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Set dic = Nothing
End If
End If
Application.ScreenUpdating = True
End Sub

 

[Thyag]

Here is some code. It will create a new worksheet listing all of the unique
items...

Public Sub GetUniqueItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Object 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed

Application.ScreenUpdating = False
'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)
If rngToSearch Is Nothing Then Set rngToSearch = ActiveCell

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = CreateObject("Scripting.Dictionary")

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) And cell.Value <> Empty Then
'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
End If
Next

If Not dic Is Nothing Then 'Check for dictionary
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For Each dicItem In dic.Items 'Loop through dictionary
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = dicItem 'Add items to new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next dicItem
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Set dic = Nothing
End If
End If
Application.ScreenUpdating = True
End Sub

--
HTH...

Jim Thomlinson








- Show quoted text -

Thanks Every body, the info I got is very useful.