![]()
Sub HelpExc() Dim d As Object: Set d = CreateObject("Scripting.Dictionary") Dim ws As Worksheet: Set ws = Sheets("Sheet1") Dim i As Long For i = 1 To ws.Range("A" & Rows.Count).End(xlUp).Row If d.Exists(ws.Range("A" & i).Value) Then ws.Range("B" & i).Value = d.Item(ws.Range("A" & i).Value) d.Item(ws.Range("A" & i).Value) = CLng(d.Item(ws.Range("A" & i).Value) + 1) Else d.Item(ws.Range("A" & i).Value) = 1 End If Next i End Sub
Bookmarks