Copy cells from specified column, removing duplicates

I'm newbie in VBA, what I need to do is to copy rows from specified column into a column on the other w开发者_如何学Corksheet, but I want to copy just one occurance of each word, for example

Column "F"
dog
dog
cat
dog

In the result I need to have new Worksheet called "Animals" with:

Column "A"    Column "B"
1             dog
2             cat

Here is a sub routine that will do exactly what you want: slap a list of unique elements in Sheet1 column F into column A of sheet2 and rename the sheet "animals". You could tweak this so that instead of it changing the name of sheet2 it can create a new sheet if you like.

Sub UniqueList()

Application.ScreenUpdating = False
Dim lastRow As Long
Dim i As Long
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")

Sheet1.Activate
lastRow = Sheet1.Cells(Rows.count, "F").End(xlUp).row

On Error Resume Next
For i = 1 To lastRow
    If Len(cells(i, "F")) <> 0 Then
        dictionary.Add cells(i, "F").Value, 1
    End If
Next

Sheet2.range("a1").Resize(dictionary.count).Value = _
Application.Transpose(dictionary.keys)

Application.ScreenUpdating = True
MsgBox dictionary.count & " unique cell(s) were found and copied."

End Sub

How it works: I use a dictionary file, which will automatically take out any dupes, then slap the list of entries into sheet2.

Do you need to do this in VBA at all?

If you just want to get a unique copy of your list, select the unsorted, non-unique column contents including the header, then hit the Advanced... button on the Sort and Filter pane of the Data ribbon. You can ask it to copy to another location and tick Unique records only.

Recording this activity and looking at the VBA, this is how it looks:

Range("A1:A4").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True

here is a solution:

Option Explicit
Sub copyNoDuplicates()
Dim rLastCell As Range
Dim cell As Range, i As Long
Dim cAnimals As Collection
Set cAnimals = New Collection
With ActiveWorkbook.Worksheets("Sheet1")
    'Find last used cell
    Set rLastCell = .Range("F65536").End(xlUp)
    'Parse every animal and put it in a collection
    On Error Resume Next
    For Each cell In .Range("F2:F" & rLastCell.Row)
        cAnimals.Add cell.Value, CStr(cell.Value)
    Next cell
    On Error GoTo 0
End With
With ActiveWorkbook.Worksheets("Sheet2")
    For i = 1 To cAnimals.Count
        .Range("A" & i).Value = i
        .Range("B" & i).Value = cAnimals(i)
    Next i
End With
End Sub