Option Explicit
Sub AnzahlTexte()
Const cSPALTE As String = "K"
Const cZIEL As String = "B1"
Dim oSl As Object
Set oSl = CreateObject("System.Collections.Sortedlist")
Dim rngTexte As Range, c As Range, x As Long, z As Long
With Columns(cSPALTE)
Set rngTexte = Range(.Cells(1), .Cells(.Cells.Count).End(xlUp))
End With
On Error Resume Next
For Each c In rngTexte
If c.Value <> "" Then oSl.Add Trim(c.Value), 1
Next c
On Error GoTo 0
Range(Range(cZIEL), Range(cZIEL).End(xlDown)).Resize(, 2).ClearContents
Set c = Range(cZIEL)
For x = 0 To oSl.Count - 1
c.Value = oSl.GetKey(x)
c.Offset(, 1).Value = WorksheetFunction.CountIf(rngTexte, c.Value)
Set c = c.Offset(1)
Next x
End Sub