Option Explicit
Private Sub Datenübertragen()
Dim ws As Excel.Worksheet
Set ws = ActiveSheet
Dim lrow1 As Integer
Dim lrow2 As Integer
Dim lcol As Integer
Dim i As Integer, x As Integer
Dim search As Variant
Dim y As Integer
Dim i2 As Integer
lrow1 = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lrow2 = Srow
For i = Srow To lrow1
For x = 2 To lrow2
lcol = ws.Cells(x, ws.Columns.Count).End(xlToLeft).Column
If ws.Cells(i, 1).Value = ws.Cells(x, 1).Value Then
Call ws.Range(ws.Cells(x, 6), ws.Cells(x, lcol)).Copy(Destination:=ws.Range("F" & i))
i2 = i
i = i + 1
For y = 6 To lcol
ws.Cells(i, y) = Application.WorksheetFunction.SumIfs( _
Worksheets("Data_Input").Range("D:D"), _
Worksheets("Data_Input").Range("A:A"), _
ws.Cells(i2, y), _
Worksheets("Data_Input").Range("B:B"), _
ws.Cells(i2, 4))
Next y
End If
Next x
Next i
End Sub