Option Explicit

Sub order_list()
Dim rng As Range, c As Range, cella As Range, firstaddress, f As Long, i As Integer

    [D:D].ClearContents
    [D1] = "num"
    Set rng = [A1].CurrentRegion

    rng.Sort key1:="data", order1:=xlAscending, header:=xlYes

    For Each cella In rng.Offset(1).Resize([COUNTA(A:A)] - 1, 1)
        f = 0
        With rng
            Set c = .Find(cella, LookIn:=xlValues)
            If Not c Is Nothing And c.Offset(, 3) = "" Then
                f = f + 1
                i = i + 1
                c.Offset(, 3) = i
                If f > 0 Then
                    firstaddress = c.Address
                    Do
                        c.Offset(, 3) = i
                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> firstaddress
                End If
            End If
        End With
    Next
    
    rng.Sort key1:="num", order1:=xlAscending, header:=xlYes
    [D:D].Delete

End Sub