Adding a count

Hope this version is ok

Try this:-
Results in column "F"

Sub MG14Sep41
Dim rng As Range
Dim Dn As Range
Dim n As Long
Dim Rw As Range
Dim K
Dim ray
Dim oRet
Dim t
Dim r
Set rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In rng
    If Not .Exists(Dn.Value) Then
        n = n + 1
        .Add Dn.Value, Dn.Offset(, 2)
    Else
Set .Item(Dn.Value) = Union(.Item(Dn.Value), Dn.Offset(, 2))
    End If
Next

For Each K In .keys
    oRet = odts(.Item(K))
        For Each Rw In .Item(K)
            For r = 0 To UBound(oRet)
                If oRet(r) = Rw Then Rw.Offset(, 3) = r + 1
            Next r
         Next Rw
Next K
End With
End Sub
Function odts(rng As Range) As Variant
Dim Dn As Range
Dim ray
Dim I As Integer
Dim J As Integer
Dim Temp As Date

With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In rng
    .Item(Dn.Value) = Dn.Value
Next Dn

ray = .keys
For I = 0 To UBound(ray)
    For J = I To UBound(ray)
        If ray(J) < ray(I) Then
            Temp = ray(I)
                ray(I) = ray(J)
                    ray(J) = Temp
        End If
    Next J
Next I
Dim r
odts = ray
End With
End Function

Regards Mick

Dear Mick.

Thanks a lot - it is working perfectly! Perhaps you can help me once again....

I had to add some additional information to the file so the layout looks different now. The problem is almost the same:
I would like to add an automatic count (f.ex. in column AN) so for each customer order (col. D) and each delivery date (col. U). For order number 2070002117 there are 2 delivery dates and I would like "1" to be shown for 13.01.2011 and "2" to be shown for 24.01.2011.....

Thanks a lot in advance.

Try this:-

Sub MG15Sep05
Dim rng     As Range
Dim Dn      As Range
Dim n       As Long
Dim Rw      As Range
Dim K       As Variant
Dim oRet    As Variant
Dim r       As Integer
Set rng = Range(Range("D2"), Range("D" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In rng
    If Not .Exists(Dn.Value) Then
        n = n + 1
        .Add Dn.Value, Dn.Offset(, 17)
    Else
Set .Item(Dn.Value) = Union(.Item(Dn.Value), Dn.Offset(, 17))
    End If
Next

For Each K In .keys
    oRet = odts(.Item(K))
        For Each Rw In .Item(K)
            For r = 0 To UBound(oRet)
                If oRet(r) = Rw Then Rw.Offset(, 19) = r + 1
            Next r
         Next Rw
Next K
End With
End Sub
Function odts(rng As Range) As Variant
Dim Dn      As Range
Dim ray     As Variant
Dim I       As Integer
Dim J       As Integer
Dim Temp    As Date

With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In rng
    .Item(Dn.Value) = Dn.Value
Next Dn

ray = .keys
For I = 0 To UBound(ray)
    For J = I To UBound(ray)
        If ray(J) < ray(I) Then
            Temp = ray(I)
                ray(I) = ray(J)
                    ray(J) = Temp
        End If
    Next J
Next I
Dim r
odts = ray
End With
End Function
End Sub

Regards Mick