Hi Johan,

Am Wed, 3 Jul 2019 23:02:39 -0700 (PDT) schrieb JS SL:

Start Situation
A E F till BZ
.. UniqueCode1 (no colored cells)
.. UniqueCode2 (no colored cells)
.. UniqueCode2 (no colored cells)
.. UniqueCode2 (one or more colored cells)

First step (cells with a color results in 1)
A E F till BZ
0 UniqueCode1 (no colored cells)
0 UniqueCode2 (no colored cells)
0 UniqueCode2 (no colored cells)
1 UniqueCode2 (one or more colored cells)

Next step (if UniqueCode is the same and one of the rows has 1 then all are 1)
A E F till BZ
0 UniqueCode1 (no colored cells)
1 UniqueCode2 (no colored cells)
1 UniqueCode2 (no colored cells)
1 UniqueCode2 (one or more colored cells)

try:

Sub Test()
Dim myRow As Range, rngC As Range, myRng As Range
Dim i As Integer, myCnt As Integer, Counter As Integer
Dim LRow As Long

With ActiveSheet
LRow = .Cells(.Rows.Count, "E").End(xlUp).Row
For Each myRow In .Range("F1:BZ" & LRow).Rows
Counter = 0
For i = .Columns("F").Column To .Columns("BZ").Column
If .Cells(myRow.Row, i).Interior.ColorIndex < xlNone Then
.Cells(myRow.Row, 1) = 1
Exit For
Else
Counter = Counter + 1
End If
Next
If Counter = 73 Then .Cells(myRow.Row, 1) = 0
Next

For i = 1 To LRow
myCnt = Application.CountIf(.Range("E1:E" & LRow), .Cells(i, "E"))
If myCnt 1 Then
Set myRng = .Cells(i, 1).Resize(myCnt)
myRng.Select
If Application.CountIf(myRng, 1) 0 Then
myRng = 1
i = i + myCnt - 1
End If
End If
Next
End With
End Sub


Regards
Claus B.
--
Windows10
Office 2016