vba confronto celle consecutive

Sub a()
Dim Ur, x
Ur = Range("A" & Rows.Count).End(xlUp).Row
    For x = 2 To Ur
        If Cells(x, 1) = Cells(x + 1, 1) Then Cells(x, 2) = Cells(x, 1)
        If Cells(x - 1, 1) = Cells(x, 1) Then Cells(x, 2) = Cells(x, 1)
    Next
End Sub

Sub a()
Dim Ur, x,  r
Ur = Range("A" & Rows.Count).End(xlUp).Row
    For x = 2 To Ur
        If Cells(x, 1) = Cells(x + 1, 1) Then Cells(x, 2) = Cells(x, 1): If r = "" Then r = x
        If Cells(x - 1, 1) = Cells(x, 1) Then Cells(x, 2) = Cells(x, 1)
        If Cells(x, 1) <> Cells(x + 1, 1) And r <> "" Then
            Cells(x, 3) = Cells(x, 1)
            Cells(x, 4) = Application.WorksheetFunction.CountIf(Range("B" & r & ":B" & x), Cells(x, 2))
            r = ""
        End If
    Next
End Sub