SOLVED

Color change with new values

Copper Contributor

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 a as seen below. I would like a new fill color each time a new value is reached, it can be alternating colors or scale I'm not picky. 

Hopefully some can help with that.

 

image.png

5 Replies

@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.

@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?

 

Anders_Svarre_0-1656317973156.png

 

@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
best response confirmed by Anders_Svarre (Copper Contributor)
Solution

@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 @Hans Vogelaar .

 

Brilliant this worked perfectly. Thank you so much and no need to apologize :)
1 best response

Accepted Solutions
best response confirmed by Anders_Svarre (Copper Contributor)
Solution

@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 @Hans Vogelaar .

 

View solution in original post