|
Ich habs mal weiter aufgebohrt. So sollte es nun jeden Fall abdecken.
Option Explicit
Sub Test()
Dim lngZeile As Long
Dim lngZeileMax As Long
Dim lngGrpCI As Long
Dim blnFoundGrp As Boolean
Dim blnFound As Boolean
lngGrpCI = 43 'Interior.ColorIndex nach dem gesucht wird
lngZeileMax = Cells(Rows.Count, "A").End(xlUp).Row
For lngZeile = 1 To lngZeileMax
If Not blnFoundGrp Then
If Cells(lngZeile, "A").Interior.ColorIndex = lngGrpCI Then
blnFoundGrp = True
End If
End If
If blnFoundGrp Then
If Cells(lngZeile, "A").Interior.ColorIndex <> lngGrpCI Then
Call Rows(lngZeile).Insert(xlShiftDown)
Cells(lngZeile, "A").Value = Cells(lngZeile - 1, "A").Value
Exit For
ElseIf Cells(lngZeile, "B").Text = "" Then
Exit For
ElseIf lngZeile = lngZeileMax Then
lngZeileMax = lngZeileMax + 1
lngZeile = lngZeileMax
Call Rows(lngZeile).Insert(xlShiftDown)
Cells(lngZeile, "A").Value = Cells(lngZeile - 1, "A").Value
Exit For
End If
End If
Next
If lngZeile > lngZeileMax Then
Call MsgBox("nichts gefunden", vbExclamation)
Exit Sub
End If
Cells(lngZeile, "B").Value = "TestB"
Cells(lngZeile, "C").Value = "TestC"
Cells(lngZeile, "D").Value = "TestD"
Cells(lngZeile, "E").Value = "TestE"
End Sub
|