@ Mullit

Public Sub test()
Const START_ROW As Long = 2
Const START_COLUMN As Long = 3
Dim blnInit As Boolean
Dim strFirstAddress As String
Dim ialngCount As Long, ialngIndex As Long
Dim lngIncr As Long
Dim avntArray() As Variant
Dim objRange As Range
Dim wksSheet As Worksheet
With Worksheets("Daten")
For ialngIndex = START_ROW To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(ialngIndex, 1)  vbNullString Then
ialngCount = 0
lngIncr = 0
For Each wksSheet In Worksheets
If wksSheet.CodeName  .CodeName Then
Set objRange = wksSheet.Columns(3).Find(What:=.Cells(ialngIndex, 1), _
After:=wksSheet.Cells(wksSheet.Cells(wksSheet.Rows.Count, 3).End(xlUp).Row, 3),  _
_
LookIn:=xlValues, LookAt:=xlWhole)
If Not objRange Is Nothing Then
strFirstAddress = objRange.Address
Do
ialngCount = ialngCount + 1
If blnInit Then
If Ubound(avntArray, 2) 
Else
Redim Preserve avntArray(.Cells(.Rows.Count, 1).End(xlUp).Row - 1, _
ialngCount * 2) As Variant
End If
avntArray(ialngIndex - START_ROW, 0) = ialngCount
avntArray(ialngIndex - START_ROW, ialngCount + lngIncr) = objRange.Offset(0, _
-2)
lngIncr = lngIncr + 1
avntArray(ialngIndex - START_ROW, ialngCount + lngIncr) = objRange.Offset(0, _
-1)
Set objRange = wksSheet.Columns(3).FindNext(After:=objRange)
Loop While Not objRange Is Nothing And objRange.Address  strFirstAddress
End If
End If
Next
If Not blnInit Then blnInit = Not blnInit
End If
Next
If .Cells(.Rows.Count, 1).End(xlUp).Row