Hallo Julia,

der obige Code funktioniert nur solange wie auch tatsächlich eine leere Zeile in den Daten vorhanden ist. Wenn alle Lücken aufgefüllt sind, schlägt der Code fehl.

DAher muss die Function GetNextEmptyRow etwas ergänzt werden:

Sub Schrittfelder()
    Rows("7:7").Copy
    With GetNextEmptyRow(Rows("11:11"))
        .Insert Shift:=xlDown
        With .Offset(RowOffset:=-1).Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        .Delete ' Heruntergeschobene Zeile löschen
    End With
    Rows("7:7").ClearContents
End Sub

Function GetNextEmptyRow(rngRow As Range) As Range
    Dim lngChkRow As Long, rngEmpty As Range
    Dim bEmptyRow As Boolean
    With rngRow.Worksheet
        For lngChkRow = rngRow.Row To .UsedRange.Row + .UsedRange.Rows.CountLarge - 1
            bEmptyRow = True
            For Each rngEmpty In Intersect(.Rows(lngChkRow), .UsedRange).Cells
                If Not IsEmpty(rngEmpty) Then
                    bEmptyRow = False
                    Exit For
                End If
            Next
            If bEmptyRow Then
                Set GetNextEmptyRow = .Rows(lngChkRow)
                Exit For
            End If
        Next
    End With
    If Not bEmptyRow Then
        Set GetNextEmptyRow = rngRow.Worksheet.Rows(lngChkRow)
    End If
End Function

Falls in den Daten keine leere Zeile vorhanden sein sollte, wird am Ende auf eine leere Zeile verwiesen.

Nur zur Info: Dieses Verfahren funktioniert nur solange, wie in Excel nicht alle 1 Mio. Zeilen aufgefüllt sind. Sobald tatsächliche keine freien Zeilen in der Tabelle mehr vorhanden sein sollte, wird dieser Code dennoch fehlschlagen.

LG, Ben