Sub Rote_Zeile()
Dim Bereich As Range
Dim LCol As Long
'Wenn in Zeile 1 die Überschrift ist
Set Bereich = Range("A3", Cells(Rows.Count, 1).End(xlUp))
Set Bereich = Bereich.Offset(0, Columns.Count - 1)
LCol = Cells(1, Columns.Count).End(xlToLeft).Column
With Application
.ScreenUpdating = False
Bereich.FormulaR1C1 = "=IF(AND(RC1<>R[-1]C1,R[-1]C1<>"""",RC1<>""""),0,"""")"
If .WorksheetFunction.CountIf(Bereich, 0) > 0 Then
Bereich.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Insert xlDown
For Each Bereich In Bereich.SpecialCells(xlCellTypeFormulas, 1)
With Bereich
Range(Cells(.Row - 1, 1), Cells(.Row - 1, LCol)).Interior.ColorIndex = 3
End With
Next Bereich
End If
Columns(Columns.Count).Delete
.ScreenUpdating = True
End With
Gruß Tino
Sub RoteZeile()
Dim lngI As Long, lngLastRow As Long
Dim varHelp As Variant
With ThisWorkbook.ActiveSheet
lngLastRow = .Cells(65536, 1).End(xlUp).Row
varHelp = .Cells(lngLastRow, 1)
For lngI = lngLastRow - 1 To 1 Step -1
If .Cells(lngI, 1) varHelp Then
.Cells(lngI + 1, 1).EntireRow.Insert Shift:=xlDown
.Cells(lngI + 1, 1).EntireRow.Interior.ColorIndex = 3
varHelp = .Cells(lngI, 1)
End If
Next lngI
End With
End Sub
Gruß Heiko
PS: Rückmeldung wäre nett !
Sub RoteZeile()
Dim lngI As Long, lngLastRow As Long
Dim varHelp As Variant
With ThisWorkbook.ActiveSheet
lngLastRow = .Cells(65536, 1).End(xlUp).Row
varHelp = .Cells(lngLastRow, 1)
For lngI = lngLastRow - 1 To 2 Step -1
If .Cells(lngI, 1) varHelp Then
.Cells(lngI + 1, 1).EntireRow.Insert Shift:=xlDown
.Cells(lngI + 1, 1).EntireRow.Interior.ColorIndex = 3
varHelp = .Cells(lngI, 1)
End If
Next lngI
End With
End Sub
Gruß Heiko
PS: Rückmeldung wäre nett !