وعليكم السلام ورحة الله،
جرب هذا الكود :
Sub test()
Dim Lr As Integer
Dim Dt As Date
Dim Tb()
Lr = [B10000].End(xlUp).Row
Set Rng = Range("B2:B" & Lr)
Dt = Format("01/01/2016", "dd/mm/yyyy")
For Each cel In Rng
If cel <> Dt Then
i = i + 1
ReDim Preserve Tb(1 To 2, 1 To i)
Tb(1, i) = Dt
Tb(2, i) = cp
Dt = cel
cp = 1
Else
cp = cp + 1
End If
Next
Range("H2").Resize(UBound(Tb, 2), UBound(Tb)) = Application.Transpose(Tb)
End Sub