Option Explicit
Sub DoIt()
Const TABPOSK As String = "B2"
Const TABPOSS As String = "B2"
Const TABSUMM As String = "SummenBlatt"
Dim oWbk As Excel.Workbook
Dim owsh As Excel.Worksheet
Dim Arr() As Variant
Dim rngc As Range, rngNext As Range
Set oWbk = ThisWorkbook
With oWbk
For Each owsh In oWbk.Sheets
If owsh.Name <> TABSUMM Then
With owsh
Arr = ShtArray(owsh, TABPOSK)
With Sheets(TABSUMM)
Set rngc = Range(TABPOSS).EntireColumn.Cells(1)
Set rngNext = Range(TABPOSS).EntireColumn.Find("*", rngc, -4123, 2, , 2).Offset(1)
rngNext.Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
End With
End With
End If
Next owsh
End With
Set oWbk = Nothing
End Sub
Function ShtArray(wsh As Worksheet, rngBegin As String) As Variant
Dim c As Range
Dim arrSrc(), arrTrg()
Dim i As Long, k As Long, l As Long, z As Long
Dim strKat As String, strKde As String
With wsh
Set c = .Range(rngBegin)
strKde = c.Text
Set c = .Range(rngBegin).CurrentRegion
arrSrc = c
End With
i = (UBound(arrSrc, 2) - 1) * (UBound(arrSrc, 1) - 2)
ReDim arrTrg(1 To i, 1 To 4)
For l = 3 To UBound(arrSrc, 1)
strKat = arrSrc(l, 1)
For k = 2 To UBound(arrSrc, 2)
z = z + 1
arrTrg(z, 1) = strKde
arrTrg(z, 2) = strKat
arrTrg(z, 3) = arrSrc(l, k)
arrTrg(z, 4) = arrSrc(2, k)
Next k
Next l
ShtArray = arrTrg
End Function