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
|