Hi David,

Thanks for the rep!

See if this works for you (I couldn't upload your image): Pequeno.xlsb

Sub Pequeno(): Dim r As Long, c As Long, Key As String, k, er As Long, S As String
With CreateObject("Scripting.Dictionary")
For r = 3 To 38: For c = 153 To 157
Key = Cells(r, c) & "_" & Cells(r, 167)
If .Exists(Key) Then
.Item(Key) = .Item(Key) + 1
Else
.Item(Key) = 1: End If
Next c: Next r
k = .Keys(): er = UBound(k) + 1
BubbleK:
        For r = LBound(k) To UBound(k) - 1
        If Val(Mid(k(r), 1, InStr(1, k(r), "_") - 1)) > _
        Val(Mid(k(r + 1), 1, InStr(1, k(r + 1), "_") - 1)) Then
    Key = k(r): k(r) = k(r + 1): k(r + 1) = Key
         GoTo BubbleK: End If: Next r
         
Cells(3, 169).Resize(UBound(k) + 1, 1).Value = WorksheetFunction.Transpose(k)
For r = 3 To er + 2: Key = Cells(r, 169): Cells(r, 169).Resize(1, 2).Value = Split(Key, "_")
Cells(r, 171) = .Item(Key): Next r
Range(Cells(3, 169), Cells(er + 2, 171)).Sort Key1:=Cells(3, 170), Header:=xlNo
For r = 3 To er + 2
S = Cells(r, 170) & Cells(r, 169): Range(S) = Cells(r, 171)
Next r
End With: End Sub