Option Explicit
Sub tabellen_verwurschteln()
Dim eins
Dim zwei
Dim drei
Dim neu
Dim ende1 As Long
Dim ende2 As Long
Dim ende3 As Long
Dim zeile As Long
Dim artikel()
Dim i As Long
Dim j As Long
Dim k As Long
Application.ScreenUpdating = False
Set eins = Worksheets(1)
Set zwei = Worksheets(2)
Set drei = Worksheets(3)
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set neu = ActiveSheet
neu.Name = "Zusammenfassung"
neu.Cells(1, 1) = "Artikelnr"
neu.Cells(1, 2) = "Bezeichnung"
neu.Cells(1, 3) = "Karton"
neu.Cells(1, 4) = "xc"
neu.Cells(1, 5) = "Big"
zeile = 2
ende1 = eins.Cells(Rows.Count, 1).End(xlUp).Row
ende2 = zwei.Cells(Rows.Count, 1).End(xlUp).Row
ende3 = drei.Cells(Rows.Count, 1).End(xlUp).Row
ReDim artikel(0)
artikel(0) = 0
For i = 2 To ende1
If eins.Cells(i, 1) <> "" Then
artikel(0) = artikel(0) + 1
ReDim Preserve artikel(artikel(0))
artikel(artikel(0)) = eins.Cells(i, 1)
If Application.WorksheetFunction.CountIf(zwei.Columns(1), eins.Cells(i, 1)) > 0 Then
For j = 2 To ende2
If zwei.Cells(j, 1) <> "" Then
If zwei.Cells(j, 1) = eins.Cells(i, 1) Then
neu.Cells(zeile, 1) = eins.Cells(i, 1)
neu.Cells(zeile, 2) = eins.Cells(i, 2)
neu.Cells(zeile, 3) = zwei.Cells(j, 2)
neu.Cells(zeile, 4) = zwei.Cells(j, 3)
For k = 1 To ende3
If zwei.Cells(j, 2) = drei.Cells(k, 1) Then neu.Cells(zeile, 5) = drei.Cells(k, 3)
Next k
zeile = zeile + 1
End If
End If
Next j
Else
neu.Cells(zeile, 1) = eins.Cells(i, 1)
neu.Cells(zeile, 2) = eins.Cells(i, 2)
zeile = zeile + 1
End If
End If
Next i
For i = 2 To ende2
If zwei.Cells(i, 1) <> "" Then
If UBound(Filter(artikel, zwei.Cells(i, 1))) > -1 Then
Else
neu.Cells(zeile, 1) = zwei.Cells(i, 1)
neu.Cells(zeile, 3) = zwei.Cells(i, 2)
neu.Cells(zeile, 4) = zwei.Cells(i, 3)
For k = 1 To ende3
If zwei.Cells(i, 2) = drei.Cells(k, 1) Then neu.Cells(zeile, 5) = drei.Cells(k, 3)
Next k
zeile = zeile + 1
End If
End If
Next i
Set eins = Nothing
Set zwei = Nothing
Set drei = Nothing
Set neu = Nothing
Application.ScreenUpdating = True
End Sub