"Unique" filter allowing duplicates

A quick help, but not a full answer to the issue can be

Sub Uniques1()

Dim a As Long, j As Long, x As Long

    Application.ScreenUpdating = False

'Find number of rows to copy
    
    a = Range("A65536").End(xlUp).Row

'Filter Unique values
    Call Treat
    j = Range("I65536").End(xlUp).Row
'Assign Group Names to each unique value
    Range("J2").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("J2:J" & j).Select
    Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
        Step:=1, Trend:=False
    
'Index/Match to Groups
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "=INDEX(C[8],MATCH(RC[-1],C[7],0))"
    Range("B2").Select
    Selection.Copy
    Range("B2:B" & a).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
'Convert to values
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("A2").Select
    
' Sort by Col D

    Range("I2:I" & j).Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("I2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("I2:I" & j)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("I1").Select
'
    Application.ScreenUpdating = True
    
End Sub

Sub Treat()
Dim ObjDic   As Object
Set ObjDic = CreateObject("Scripting.Dictionary")
Dim LR  As Long
Dim WkRg  As Range
Dim F  As Range
    Set WkRg = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    With ObjDic
        For Each F In WkRg
            .Item(F.Value) = Empty
        Next F
        Range("I2:I" & Range("I" & Rows.Count).End(xlUp).Row + 1).ClearContents
        Range("I2").Resize(.Count, 1) = Application.Transpose(.keys)
    End With
End Sub

For some reason the advanced filter insists on working with a header included. So... you when you filter the range starting at row 2 (so skipping the real header), whatever the first record is will be copied both as a header and (if there is another instance), also as a unique value.

I suggest you change this line:

Range("A2:A" & a).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "I2"), Unique:=True

to this (it will include the header in the copy to the unique list, but paste into I1 instead of 2, then since you sort I2 and down, your header will stay put and your list will be unique

Range("A1:A" & a).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "I1"), Unique:=True

Ochimus,
I have yet to meet someone who has achieved that goal.... though some are incredibly close (and I am certainly not one of them). Happy to have been of use

Well I proposed a wrong answer first and then got a new one.
For the fun a remake of the macro.
BTW it looks to me that the way your macro is preparing the group formula is done a bit too early and then the group is not correct
"Sort by Col D " is done at the end and only for column I

Sub Uniques2()
Dim objSortedList  As Object
Set objSortedList = CreateObject("System.Collections.Sortedlist")
Dim F  As Range
Dim i As Long
    With objSortedList
        For Each F In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
            If (Not (.Contains(F.Value))) Then .Add F.Value, Empty
        Next F
        Range("I2:J" & Range("I" & Rows.Count).End(xlUp).Row + 1).ClearContents
        For i = 0 To .Count - 1
            Range("I2").Offset(i, 0) = .GetKey(i)
            Range("I2").Offset(i, 1) = i + 1
        Next i
    End With
    With Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)
        .FormulaR1C1 = "=INDEX(C[8],MATCH(RC[-1],C[7],0))"
        .Value = .Value
    End With
End Sub