08.04.2021, 14:24
Hallo Wolfgang,
teste mal damit:
Gruß Uwe
teste mal damit:
Code:
Sub KreuzeReinRaus()
Dim rngT As Range, rngZ As Range
Dim lngE As Long
lngE = Application.Match("Wochenliste in Datenbank übernommen", Columns(12))
For Each rngT In Range("D6:Q6")
If rngT.DisplayFormat.Interior.Color = 255 Then
For Each rngZ In rngT.Offset(2).Resize(lngE - 8).Cells
If rngZ.MergeCells Or Cells(rngZ.Row, 1).MergeCells Then
With rngZ.Borders(xlDiagonalUp)
.LineStyle = 1
.Weight = xlMedium
.Color = RGB(0, 0, 0)
End With
With rngZ.Borders(xlDiagonalDown)
.LineStyle = 1
.Weight = xlMedium
.Color = RGB(0, 0, 0)
End With
End If
Next rngZ
Else
With rngT.Offset(2).Resize(lngE - 8)
.Borders(xlDiagonalUp).LineStyle = -4142
.Borders(xlDiagonalDown).LineStyle = -4142
End With
End If
Next rngT
End SubGruß Uwe