Sub uuu()
    Dim a(), b()
    Dim i&, ii
    a = Range("A2:C" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a)
            .Item(a(i, 2)) = .Item(a(i, 2)) + 1
        Next
        For Each key_ In .Keys
            If .Item(key_) > 1 Then .Remove (key_)
        Next
        ii = 1
        ReDim b(1 To .Count, 1 To UBound(a, 2))
        For Each key_ In .Keys
            For i = 1 To UBound(a)
                If a(i, 2) = key_ Then
                     b(ii, 1) = a(i, 1)
                     b(ii, 2) = a(i, 2)
                     b(ii, 3) = a(i, 3)
                     ii = ii + 1
                End If
            Next
        Next
    End With
    Cells(2, 5).Resize(UBound(b), UBound(b, 2)) = b
End Sub