Option Explicit

Sub DoIt()
Const TABPOSK As String = "B2" 'Position Kundenname (Rest wie Grafik1 - ohne Leerzellen)
Const TABPOSS As String = "B2" 'Position Summenblatt Überschrift - VORHANDEN !
Const TABSUMM As String = "SummenBlatt"   'Blattname Ergenisliste
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      'Block steht frei !!!
   'oder Block für 4 Zeilen, 12 Monate breit
   'Set c = Range(.Range(rngBegin), .Range(rngBegin).Offset(4, 12))
   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