Копировать ячейки из указанного столбца, удаляя дубликаты

Question

Я новичок в VBA, мне нужно скопировать строки из указанного столбца в столбец на другом листе, но я хочу скопировать только одно вхождение каждого слова, например

Column "F"
dog
dog
cat
dog

В результате мне нужно иметь новый рабочий лист под названием «Животные» с:

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

Answer 1

Вот подпрограмма, которая будет делать именно то, что вы хотите: добавьте список уникальных элементов в столбце F листа 1 в столбец A листа 2 и переименуйте лист "животные".Вы можете настроить это так, чтобы вместо изменения имени листа2 он мог создать новый лист, если хотите.

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

Как это работает: Я использую файл словаря, которыйавтоматически удалит все дубликаты, а затем добавит список записей в sheet2.

Answer 2

Вам вообще нужно делать это в VBA?

Если вы просто хотите получить уникальную копию своего списка, выберите несортированное, неуникальное содержимое столбца, включая заголовок, затем нажмите «Дополнительно».... на панели Сортировка и фильтр на ленте данных.Вы можете попросить его скопировать в другое место и отметить только Уникальные записи.

Запись этого действия и просмотр VBA, вот как это выглядит:

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

Answer 3

вот решение:

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