Hallo,

vielleicht hilft dieser Code weiter:

Sub AnalyzeAndCopy()
    Dim wsh As Worksheet
    Dim rngChk As Range
    Dim rngData As Range
    Dim wshNew As Worksheet
    Set wsh = ThisWorkbook.Worksheets(1)
    
    
    Set rngData = wsh.Range(wsh.Cells(3, 7), wsh.Cells(wsh.UsedRange.Count + wsh.UsedRange.Top, 24))
    Stop
    For Each rngChk In rngData.Cells
        If Not rngChk.Value = "" Then
            If wshNew Is Nothing Then
                Set wshNew = CreateNewWorkbook
            End If
            AddNewValue wshNew, rngChk
        End If
    Next
End Sub

Function CreateNewWorkbook() As Worksheet
    Dim wbk As Workbook
    Dim wsh As Worksheet
    
    Set wbk = Application.Workbooks.Add()
    Set wsh = wbk.Worksheets(1)
    
    wsh.Range("A1").Value = "kreditor"
    wsh.Range("B1").Value = "kunde"
    With wsh.Range("C:C")
        .Cells(1, 1).Value = "datum"
        .NumberFormat = "m/d/yyyy"
    End With
    With wsh.Range("D:D")
        .Cells(1, 1).Value = "betrag"
        .NumberFormat = "_-* #,##0.00 [$€-407]_-;-* #,##0.00 [$€-407]_-;_-* ""-""?? [$€-407]_-;_-@_-"
    End With
    
    wsh.Range("E1").Value = "kostenstelle"
    wsh.Range("F1").Value = "gegenkonto"
    Set CreateNewWorkbook = wsh
End Function

Sub AddNewValue(wshOutSheet As Worksheet, rngMoney As Range)
    Dim rngWrite As Range
    Dim rngKreditor As Range
    Set rngWrite = Intersect(wshOutSheet.Range("A:A"), wshOutSheet.UsedRange).Offset(rowOffset:=1)
    Set rngWrite = wshOutSheet.Cells(wshOutSheet.UsedRange.Rows.Count + 1, 1)
    Set rngKreditor = rngMoney.Worksheet.Cells(rngMoney.Row, 3)
    rngWrite.Value = rngKreditor.Value
    rngWrite.Offset(ColumnOffset:=1).Value = rngKreditor.Offset(ColumnOffset:=1).Value
    rngWrite.Offset(ColumnOffset:=2).Value = rngKreditor.Offset(ColumnOffset:=3).Value
    rngWrite.Offset(ColumnOffset:=3).Value = rngMoney.Value
    rngWrite.Offset(ColumnOffset:=4).Value = rngMoney.EntireColumn.Cells(1, 1).Value
    rngWrite.Offset(ColumnOffset:=5).Value = rngMoney.EntireColumn.Cells(2, 1).Value
End Sub

Um die Werte zu kopieren, muss der Befehl AnalyzeAndCopy aufgerufen werden.

LG, BigBen