Forum Discussion

Anders_Svarre's avatar
Anders_Svarre
Copper Contributor
Jun 24, 2022
Solved

Color change with new values

Hi.   I'm trying format my sheet so that it changes color every time a line with a new value is reached. The table I'm working with will have a random number of lines with the same value in column ...
excel
  • OliverScheurich's avatar
    OliverScheurich
    Jun 27, 2022

    Anders_Svarre 

    Sub color()

Dim i As Double
Dim k As Integer
Dim MaxRow As Double

Range("A:A").Interior.ColorIndex = xlNone

MaxRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To MaxRow

If Cells(i, 1).Value = Cells(i + 1, 1).Value Then

Cells(i, 1).Interior.ColorIndex = 4 + k
Cells(i + 1, 1).Interior.ColorIndex = 4 + k

Else

k = k + 1

If k = 50 Then
k = 4
Else
End If

If Cells(i + 1, 1).Value = "" Then
Else
Cells(i + 1, 1).Interior.ColorIndex = 4 + k
End If

End If

Next i

End Sub

    Sorry for the mistake. In the attached file i've tested the code for more than 40000 rows and it should work now.

     

    Meanwhile you've already received two easier solutions from HansVogelaar .

     

OliverScheurich's avatar
OliverScheurich
Gold Contributor
Jun 25, 2022

Anders_Svarre 

Sub color()

Dim i As Integer
Dim k As Integer
Dim MaxRow As Integer

Range("A:A").Interior.ColorIndex = xlNone

MaxRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = 3 To MaxRow

If Cells(i, 1).Value = Cells(i + 1, 1).Value Then

Cells(i, 1).Interior.ColorIndex = 4 + k
Cells(i + 1, 1).Interior.ColorIndex = 4 + k

Else

k = k + 1

If k = 60 Then
k = 4
Else
End If

If Cells(i + 1, 1).Value = "" Then
Else
Cells(i + 1, 1).Interior.ColorIndex = 4 + k
End If

End If

Next i

End Sub

Maybe with this code. In the attached file you can click the button in cell C2 to start the macro.

Anders_Svarre's avatar
Anders_Svarre
Copper Contributor
Jun 27, 2022

OliverScheurich 

Thank you, this is exactly what I'm looking for. Unfortunately the macro has an error, I'm  a completed noob in this so I couldn't fix it my self. Would you mind having a second look at it to see if you can fix it?

 

 

  • OliverScheurich's avatar
    OliverScheurich
    Gold Contributor
    Jun 27, 2022

    Anders_Svarre 

    Sub color()

Dim i As Double
Dim k As Integer
Dim MaxRow As Double

Range("A:A").Interior.ColorIndex = xlNone

MaxRow = Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To MaxRow

If Cells(i, 1).Value = Cells(i + 1, 1).Value Then

Cells(i, 1).Interior.ColorIndex = 4 + k
Cells(i + 1, 1).Interior.ColorIndex = 4 + k

Else

k = k + 1

If k = 50 Then
k = 4
Else
End If

If Cells(i + 1, 1).Value = "" Then
Else
Cells(i + 1, 1).Interior.ColorIndex = 4 + k
End If

End If

Next i

End Sub

    Sorry for the mistake. In the attached file i've tested the code for more than 40000 rows and it should work now.

     

    Meanwhile you've already received two easier solutions from HansVogelaar .

     

    • Anders_Svarre's avatar
      Anders_Svarre
      Copper Contributor
      Jun 27, 2022
      Brilliant this worked perfectly. Thank you so much and no need to apologize 🙂
  • HansVogelaar's avatar
    HansVogelaar
    MVP
    Jun 27, 2022

    Anders_Svarre 

    How about

    Sub color()
    Dim i As Integer
    Dim k As Integer
    Dim MaxRow As Integer
    k = 2
    Range("A:A").Interior.ColorIndex = xlNone
    MaxRow = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To MaxRow
        If Cells(i, 1).Value <> Cells(i - 1, 1).Value Then
            k = k + 1
            If k > 56 Then
                k = 3
            End If
        End If
        Cells(i, 1).Interior.ColorIndex = k
    Next i
End Sub

     or

    Sub color()
    Dim i As Integer
    Dim k As Integer
    Dim MaxRow As Integer
    k = 3
    Range("A:A").Interior.ColorIndex = xlNone
    MaxRow = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To MaxRow
        If Cells(i, 1).Value <> Cells(i - 1, 1).Value Then
            k = 7 - k
        End If
        Cells(i, 1).Interior.ColorIndex = k
    Next i
End Sub

Resources