SOLVED

Auto fill color cells based on value of another color filled cell

Copper Contributor

I need help with an Excel macro that can analyze a numeric value within a cell that also contains a fill color (yellow) and it fill that same color into all cells having the same numeric value. I don't think that I can use any type of conditional formatting nor place a formula within the cells as I already have on in the cells that auto number the cells based on a value within another cell, i.e. =IF(C113336="region",F113335+1,F113335).

 

The below is an example of what I need. The forum doesn't allow for color filling the cells so I used bold Red. 

What I have now

UNIT MATCHATTRIBUTE NAMEATTRIBUTE VALUECLASS CODERULESET
TERM-1/0-AL-25KV-PregionPTerminations 1p29949
TERM-1/0-AL-25KV-Priser_typeSingleTerminations 1p29949
TERM-1/0-AL-25KV-Pnominal_voltage4.16/2.4 kVTerminations 1p29949
TERM-1/0-AL-25KV-Pphase_count1Terminations 1p29949
TERM-1/0-AL-25KV-Pug_pri_wire_size1/0Terminations 1p29949
TERM-1/0-AL-25KV-PregionPTerminations 1p29950
TERM-1/0-AL-25KV-Priser_typeSingleTerminations 1p29950
TERM-1/0-AL-25KV-Pnominal_voltage12.47/7.2 kVTerminations 1p29950
TERM-1/0-AL-25KV-Pphase_count1Terminations 1p29950
TERM-1/0-AL-25KV-Pug_pri_wire_size1/0Terminations 1p29950
TERM-1/0-AL-25KV-PregionPTerminations 1p29951
TERM-1/0-AL-25KV-Priser_typeSingleTerminations 1p29951
TERM-1/0-AL-25KV-Pnominal_voltage13.8/8.0 kVTerminations 1p29951
TERM-1/0-AL-25KV-Pphase_count1Terminations 1p29951
TERM-1/0-AL-25KV-Pug_pri_wire_size1/0Terminations 1p29951
TERM-1/0-AL-25KV-PregionPTerminations 1p29952
TERM-1/0-AL-25KV-Priser_typeSingleTerminations 1p29952
TERM-1/0-AL-25KV-Pnominal_voltage13.2/7.6 kVTerminations 1p29952
TERM-1/0-AL-25KV-Pphase_count1Terminations 1p29952
TERM-1/0-AL-25KV-Pug_pri_wire_size1/0Terminations 1p29952

 

What I'm looking for after the macro runs. Note: I'm open to using color text vs a cell fill color if that is the bet option.

UNIT MATCHATTRIBUTE NAMEATTRIBUTE VALUECLASS CODERULESET
TERM-1/0-AL-25KV-PregionPTerminations 1p29949
TERM-1/0-AL-25KV-Priser_typeSingleTerminations 1p29949
TERM-1/0-AL-25KV-Pnominal_voltage4.16/2.4 kVTerminations 1p29949
TERM-1/0-AL-25KV-Pphase_count1Terminations 1p29949
TERM-1/0-AL-25KV-Pug_pri_wire_size1/0Terminations 1p29949
TERM-1/0-AL-25KV-PregionPTerminations 1p29950
TERM-1/0-AL-25KV-Priser_typeSingleTerminations 1p29950
TERM-1/0-AL-25KV-Pnominal_voltage12.47/7.2 kVTerminations 1p29950
TERM-1/0-AL-25KV-Pphase_count1Terminations 1p29950
TERM-1/0-AL-25KV-Pug_pri_wire_size1/0Terminations 1p29950
TERM-1/0-AL-25KV-PregionPTerminations 1p29951
TERM-1/0-AL-25KV-Priser_typeSingleTerminations 1p29951
TERM-1/0-AL-25KV-Pnominal_voltage13.8/8.0 kVTerminations 1p29951
TERM-1/0-AL-25KV-Pphase_count1Terminations 1p29951
TERM-1/0-AL-25KV-Pug_pri_wire_size1/0Terminations 1p29951
TERM-1/0-AL-25KV-PregionPTerminations 1p29952
TERM-1/0-AL-25KV-Priser_typeSingleTerminations 1p29952
TERM-1/0-AL-25KV-Pnominal_voltage13.2/7.6 kVTerminations 1p29952
TERM-1/0-AL-25KV-Pphase_count1Terminations 1p29952
TERM-1/0-AL-25KV-Pug_pri_wire_size1/0Terminations 1p29952
4 Replies

@ronngrimes 

You can try these lines of code. In the attached file you can click the button in cell G2 to start the macro.

Sub fontcolor()

Dim i As Integer
Dim j As Integer

For i = 1 To 20
If Cells(i, 5).Font.Color <> 3355443 Then

For j = 23 To 42

If Cells(j, 5).Value = Cells(i, 5).Value Then
Cells(j, 5).Font.Color = Cells(i, 5).Font.Color

Else

End If

Next j

Else

End If
Next i

End Sub

Thanks for your help. The code works to some degree.

I should have been a little more clear. The two examples I provided where the same data samples and the first one was to show what I have to start with and the second one was to show what I need it to look like after running the macro.

Your code calls for using the font color which will work well. I modify your code so that it would change the color in the first 20 rows.

You have
For i = 1 To 20
If Cells(i, 5).Font.Color <> 3355443 Then

For j = 23 To 42

Rows 23-42 are the exact same data as 1-20. So I modified it to be

For i = 1 To 20
If Cells(i, 5).Font.Color <> 3355443 Then

For j = 1 To 20

This works in the very small sample of data. However, my spreadsheet has over 261.900 rows of data. Currently I'm trying to update a small subset of those rows 113336 - 120303. When I modified your code, I keep getting a Run Time error 6 Overflow.

Am I doing something wrong in my edits or is my spreadsheet too large?

best response confirmed by ronngrimes (Copper Contributor)
Solution

@ronngrimes 

The error message was because of the datatype Integer. For this code i used the datatype Long (in rows 3, 4 and 5 of the code) which can be used for much bigger values than Integer.

 

Actually the standard fontcolor in Excel is 0 therefore i changed row 10 of the code. Fontcolor 3355443 was returned after pasting the data into Excel.

 

In the attached file i've tested the code for range E100000:E110000 and it returns the expected result.

Sub fontcolor()

Dim i As Long
Dim j As Long
Dim MaxRow As Long

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

For i = 100000 To MaxRow
If Cells(i, 5).Font.Color <> 0 Then

For j = 100000 To MaxRow

If Cells(j, 5).Value = Cells(i, 5).Value Then
Cells(j, 5).Font.Color = Cells(i, 5).Font.Color

Else

End If

Next j

Else

End If
Next i

End Sub

 

Excellent, works great. Thank you for you help. I have thousands of rows of data to clean up and this will make it go a lot faster.
1 best response

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

@ronngrimes 

The error message was because of the datatype Integer. For this code i used the datatype Long (in rows 3, 4 and 5 of the code) which can be used for much bigger values than Integer.

 

Actually the standard fontcolor in Excel is 0 therefore i changed row 10 of the code. Fontcolor 3355443 was returned after pasting the data into Excel.

 

In the attached file i've tested the code for range E100000:E110000 and it returns the expected result.

Sub fontcolor()

Dim i As Long
Dim j As Long
Dim MaxRow As Long

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

For i = 100000 To MaxRow
If Cells(i, 5).Font.Color <> 0 Then

For j = 100000 To MaxRow

If Cells(j, 5).Value = Cells(i, 5).Value Then
Cells(j, 5).Font.Color = Cells(i, 5).Font.Color

Else

End If

Next j

Else

End If
Next i

End Sub

 

View solution in original post