Speed up Loop VBA

[Admin]

Hi,

Give it a try

Sub kTest()
    
    Dim Data, i As Long, Pos(), UnqList
    Dim r   As Long, dic As Object
    
    r = Range("a" & Rows.Count).End(xlUp).Row
    UnqList = Range("a2:a" & r)         'Unique List
    r = Range("g" & Rows.Count).End(xlUp).Row
    Data = Range("g2:g" & r)            'Original List
    ReDim Pos(1 To UBound(Data, 1), 1 To 1)
    Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
    
    For i = 1 To UBound(UnqList, 1)
        dic.Item(UnqList(i, 1)) = i
    Next
    
    For i = 1 To UBound(Data, 1)
        Pos(i, 1) = dic.Item(Data(i, 1))
    Next
    
    Range("h2").Resize(UBound(Pos, 1)) = Pos
    
End Sub