A          B       C    D  
 
2010 03	 	
           aa		5
	   bb		2
	   cc		3
 
2010 04			
	   ss		2
	   aa		4
	   cc		5
 
2010 05			
	   bb		1
	   aa		2
 
2010 06			
	   kk		2
	   aa		4
 
2010 07	   kk		3
	   bb		1

Sub Neu()
Dim intSuche As Integer
Dim rngcell As Range
Dim rngcell2 As Range
Dim c As Range
Dim CompareRange As Variant, a As Variant, b As Variant
 
With ActiveSheet
'zählt bis nächsten Datum
lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
l = 2
Do While Cells(l, 1).Value <> ","
'Suchwert festlegen (anpassen!):
Suche = "*"
 
 
Set rngcell = .Columns(1).Cells.Find(Suche, .Cells(lrow, 1), , xlWhole, , _
  xlNext)
      If Not rngcell Is Nothing Then        'wenn etwas gefunden wurde
            xZahl = rngcell          
                On Error Resume Next                            
      End If
     arrSplit1 = Split(xZahl, " ")
        If UBound(arrSplit1) >= 1 Then
             bereichLft = arrSplit1(0)
                bereichRgt = arrSplit1(1)
                     x = bereichLft & bereichRgt
        End If
Set rngcell2 = .Columns(1).Cells.FindNext(rngcell)
            yZahl = rngcell2
     arrSplit2 = Split(yZahl, " ")
        If UBound(arrSplit2) >= 1 Then
             bereichLft = arrSplit2(0)
                bereichRgt = arrSplit2(1)
                     y = bereichLft & bereichRgt
        End If
 
     If y - x = 1 Or y - x = 2 Or y - x = 3 Or y - x = 4 Then
       For l = 1 To lrow
 
             If m = lrow Then
                 Exit Sub
             End If
 
                If Cells(l, 1) = xZahl Or Cells(l, 1) = yZahl Then
                   'Zählt bis zum nächsten Datum
                   Nrows = Cells(l, 1).End(xlDown).Row
                    'Zählt bis zur letzten leere Zelle
                     Rnumber1 = Cells(Rows.Count, 2).End(xlUp).Row + 1
 
                 End If
 
        For k = l + 1 To Nrows - 2
 
               If .Sheets(1).Range("C" & k + 1) <> "" Then '+ 1
            'CompareRange fester Suchwert
                    Set CompareRange = Range("B" & k)
                End If
        For m = Nrows + 1 To Rnumber1 - 1
                    'b ist fester gesuchte Wert
                For Each b In CompareRange
                     Set a = Range("B" & m)
 
                        If a = b Then a.Offset(0, 1) = b.Offset(0, 2) + _
                          a.Offset(0, 2)
                     Exit For
 
                Next b
                    If a = b Then
                         Exit For
                    End If
           Next m
 
         Next k
 
       Next l
End If
 
'aufräumen:
    Set rngcell = Nothing: Set rngcell2 = Nothing
  Loop
    End With
End Sub