Sub qq()
    Dim tmp(), ar, i&, x&, k&, j&, oDic As Object, ark
    ar = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).Value
    Set oDic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(ar)
        If Not oDic.exists(ar(i, 1)) Then
            oDic.Item(ar(i, 1)) = 5
            x = x + 5
        End If
    Next
    ar = Range(Cells(2, 2), Cells(Rows.Count, 3).End(xlUp)).Value
    For i = 1 To UBound(ar)
        If oDic.exists(ar(i, 1)) Then
            oDic.Item(ar(i, 1)) = 5 - ar(i, 2)
            If oDic.Item(ar(i, 1)) = 0 Then oDic.Remove (ar(i, 1))
            x = x - ar(i, 2)
        End If
    Next
    ReDim tmp(1 To x, 1 To 1)
    ark = oDic.keys
    For i = 1 To UBound(tmp)
        If j = 0 Then
            j = oDic.Item(ark(k))
        End If
        If j > 0 Then
            tmp(i, 1) = ark(k)
            j = j - 1
        End If
        If j = 0 Then k = k + 1
    Next
    [f2].Resize(UBound(tmp)).Value = tmp
End Sub