Option Explicit
Sub Fett()
Dim rngB As Range, c As Range
Dim arrDp() As Variant
Dim x As Long
Set rngB = Range("B4:B3000")
rngB.Font.Bold = False
arrDp = GetDistinct(rngB)
Set rngB = rngB.Resize(rngB.Rows.Count + 1)
For x = UBound(arrDp) To LBound(arrDp) Step -1
Set c = rngB.Find(arrDp(x), rngB.Cells(rngB.Cells.Count), xlValues, xlWhole, , xlPrevious)
c.Font.Bold = True
Next x
End Sub
Function GetDistinct(ByVal oTarget As Range) As Variant
Dim varArray As Variant
Dim objMyDic As Object
Dim V As Variant
Set objMyDic = CreateObject("Scripting.Dictionary")
varArray = oTarget
For Each V In varArray
objMyDic(V) = V
Next
GetDistinct = objMyDic.Items()
End Function