Copy cells from specified column, removing duplicates - vba

Question

I'm newbie in VBA, what I need to do is to copy rows from specified column into a column on the other worksheet, 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

Answer 1

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.

Answer 2

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

Answer 3

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