Trovare valori uguali

Sub controllauguali()
Dim i As Long
Dim ur As Long
Dim riga As Long
riga = 1
ur = Cells(Rows.Count, 2).End(xlUp).Row
For i = 1 To ur
    If WorksheetFunction.CountIf(Range("c:c"), Range("B" & i).Value) > 0 And WorksheetFunction.CountIf(Range("F:f"), Range("B" & i).Value) = 0 Then
        Cells(riga, 6).Value = Range("b" & i)
        riga = riga + 1
    End If
Next i
End Sub

Sub Uguali()
Dim r, c, d, x, y, dd As New Collection

r = 1
c = 4
Range("D:D").Clear
For x = 1 To Cells(Rows.Count, 2).End(xlUp).Row
    d = Cells(x, 2)
    On Error Resume Next
    dd.Add d, CStr(d)
    On Error GoTo 0
Next x
For x = 1 To dd.Count
  d = Val(dd(x))
  For y = 1 To Cells(Rows.Count, 3).End(xlUp).Row
    If d = Cells(y, 3) Then Cells(r, c) = d: r = r + 1: Exit For
  Next y
Next x
Range("D1").CurrentRegion.Sort key1:=Range("D1"), order1:=xlAscending
End Sub