Im nowsza wersja Excela tym coraz więcej jest wbudowanych narzędzi. I tak zapewne jest z usuwaniem duplikatów. W Excelu 2003 – o ile się nie mylę? – nie było takiego narzędzia. A swego czasu pisząc aplikację do obsługi magazynu automatycznego musiałem wydobyć unikalne numery serii.

Nie pamiętam dokładnie źródła, ale wydaje mi się kod do usuwania duplikatów skopiowałem z jednej z książek Johna Walkenbacha. Poniższy kod usuwa duplikaty z komórki dodając je do kolekcji. Aby nie pojawiał się błąd, celowo do kodu dodano On Error Resume Next. Wiadomo, że z powodu użytej pętli – im więcej wierszy w kolumnie tym czas pracy kodu jest dłuższy.

Usuwanie duplikatów:

Private Sub AddNextSheets()
' TWORZENIE NOWYCH ARKUSZY NA PODSTAWIE 
' UNIKALNYCH WARTOŚCI Z KOLUMNY

Dim LicznikWierszy As Long
Dim RemoveDuplicates As New Collection
Dim NewFileName as string

NewFileName "Jakas nazwa pliku Excel"

LicznikWierszy = 10
Do Until ThisWorkbook.Sheets("SheetName").Cells(LicznikWierszy, 6) = ""

    If ThisWorkbook.Sheets("SheetName").Cells(LicznikWierszy, 6) <> "" Then
        ' Komórka nie jest pusta. Dodanie wartosci do kolekcji
        On Error Resume Next
        ' Usuwanie ewentualnych duplikatów
        RemoveDuplicates.Add ThisWorkbook.Sheets("SheetName").Cells(LicznikWierszy, 6), _
        CStr(ThisWorkbook.Sheets("SheetName").Cells(LicznikWierszy, 6))
        On Error GoTo 0
    Else
        ' Komórka jest pusta, nic sie nie dzieje
    End If
LicznikWierszy = LicznikWierszy + 1
Loop

' Dodawanie nowych arkuszy w wybranym pliku na podstawie danych z kolekcji RemoveDuplicates
Windows(NewFileName).Activate
Dim Item As Object
For Each Item In RemoveDuplicates
    ' Dodanie arkusza na końcu
    Sheets.Add After:=Workbooks(NewFileName).Sheets(Workbooks(NewFileName).Sheets.Count)
    ' Zmiana nazwy na tą z kolekcji
    Workbooks(NewFileName).Sheets(Workbooks(NewFileName).Sheets.Count).Name = Item & "-AA"
Next