# Values-specific coloured cells to retain its colour

#### XanderTheNotSoAwesome

##### New Member
Sheet 1: Has values like 33.878 in Yellow, 17.873 in Red and 96.666 in Green.

Is there a way to ensure that these coloured cells are carried over to sheet 2? (Sheet 2 has a macro that sorts out the scores according to percentile and other considerations so I can’t just copy&paste/use simple filtering or sorting and was wondering if there is a code to bring the colours-specific to its value over instead of manually colouring them)

#### jolivanes

##### Well-known Member
Which columns need to be compared?
If you compare numbers that were calculated, you have a very good chance that they appear to be the same but are not (3.45 vs 3.4512) because of decimals showing/not showing.
The codes in Posts 6 and 9 look for same values and then use the background color of found value to color the cell value.
Obviously there is more to it.

### Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.

#### XanderTheNotSoAwesome

##### New Member
Have uploaded an example of how both sheets should look like. The only thing I can’t do is replicate the colours for sheet 2. It remains uncoloured.

I have checked the values and they are all accurate even to the 8th decimal place, there are no changes to the value in both sheets.

#### Attachments

• BCEBBEC8-215E-498C-A1B9-8B4578B380FB.jpeg
211.1 KB · Views: 6
• 3E39286C-E9D7-4EB3-A9B8-FBDE74AF0187.jpeg
141.4 KB · Views: 6

#### XanderTheNotSoAwesome

##### New Member
Oh right, this is what the latest code that you’ve given does.

#### Attachments

• 349B867F-BFBC-4B6D-8A6C-0796A61EA169.jpeg
223.6 KB · Views: 4

#### jolivanes

##### Well-known Member
VBA Code:
``````Sub Try_This_Way()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim lr1 As Long, lr2 As Long
Dim rng1 As Range, rng2 As Range
Dim c As Range, cel As Range
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
lr1 = sh1.Cells(Rows.Count, 5).End(xlUp).Row
lr2 = sh2.Cells(Rows.Count, 3).End(xlUp).Row
Set rng1 = sh1.Range("E2:F" & lr1 & "," & "H2:H" & lr1)
Set rng2 = sh2.Range("C2:E" & lr2)
rng2.Interior.Color = xlNone
For Each c In rng2
For Each cel In rng1
If cel.Value = c.Value Then
c.Interior.Color = cel.Interior.Color
Exit For
End If
Next cel
Next c
End Sub``````

Check all references, ranges, sheets and whatever. Change if required.

#### jolivanes

##### Well-known Member

If you want to just compare same header columns, maybe like this.
Code:
``````Sub Per_Individual_Column()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim colSht1, colSht2
Dim lr1 As Long, lr2 As Long
Dim i As Long, c As Range
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
lr1 = sh1.Cells(Rows.Count, 5).End(xlUp).Row
lr2 = sh2.Cells(Rows.Count, 3).End(xlUp).Row
colSht1 = Array(5, 6, 8)
colSht2 = Array(3, 4, 5)
For i = LBound(colSht2) To UBound(colSht2)
For Each c In sh2.Cells(2, colSht2(i)).Resize(lr2 - 1)
If WorksheetFunction.CountIf(sh1.Cells(2, colSht1(i)).Resize(lr1 - 1), c.Value) <> 0 Then
c.Interior.Color = sh1.Cells(2, colSht1(i)).Resize(lr1 - 1).Find(c, , , 1).Interior.Color
End If
Next c
Next i
End Sub``````

#### jolivanes

##### Well-known Member
If you want to mix-up your columns, headers in different columns, use this.
It has no Column amount restriction as long as there are headers in Row 1. It uses the same headers in both sheets.
Sheet1 subject headers need to start in Column E and continue to the right while in Sheet2 this needs to be Column C.
If that changes, code needs to be changed to reflect this.
Code:
``````Sub With_Header_Array()
Dim subjCol, i As Long, c As Range
Dim sh1Col As Long, sh2Col As Long
Dim sh1 As Worksheet, sh2 As Worksheet
Dim lr1 As Long, lr2 As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
lr1 = sh1.Cells(Rows.Count, 5).End(xlUp).Row    '<---- Sheet1, Column 5 (Column E)
lr2 = sh2.Cells(Rows.Count, 3).End(xlUp).Row    '<---- Sheet2, Column 3 (Column C)
subjCol = Application.Transpose(sh2.Cells(1, 3).Resize(, sh2.Cells(1, sh2.Columns.Count).End(xlToLeft).Column - 2).Value)    '<---- Sheet2, Column 3 (Column C)
For i = LBound(subjCol) To UBound(subjCol)
If WorksheetFunction.CountIf(sh1.Rows(1), subjCol(i, 1)) <> 0 Then
sh1Col = sh1.Rows(1).Find(subjCol(i, 1)).Column
sh2Col = sh2.Rows(1).Find(subjCol(i, 1)).Column
For Each c In sh2.Cells(2, sh2Col).Resize(lr2 - 1)
If WorksheetFunction.CountIf(sh1.Cells(2, sh1Col).Resize(lr1 - 1), c.Value) <> 0 Then
c.Interior.Color = sh1.Cells(2, sh1Col).Resize(lr1 - 1).Find(c, , , 1).Interior.Color
End If
Next c
End If
Next i
End Sub``````

#### jolivanes

##### Well-known Member

In the above thread you indicate that the numbers are calculated as a percentage.
Does this still keep the values to be compared exactly the same? any difference at all and the code does not give a proper result.

#### XanderTheNotSoAwesome

##### New Member
Sorry for the late response, was down with sickness..

For your question on percentile, I thought they were initially colour coded based on percentile but that’s not the case.

The process is like this:

1. I receive Sheet 1 as it is, coloured from the Test Department after they have calculated the scores. They don’t tell me what’s the criteria for the colours, I’m just supposed to run a few macros and reach Sheet 2. (The scores don’t change, I just have to rank the students)

2. Previously, I went to colour every single cell myself, one monitor showing sheet 1 and another showing sheet 2.

That obviously created a lot of problems, first is human error and second is that if there are 200-300 students for that batch I’m basically spending a full shift at work just colouring cells which is extremely inefficient. I was told if I could come up with a macro that could automatically colour the cells, I could feel free to, but I couldn’t do it cuz I’m quite an amateur at this.

I requested help from the Test Department but they told me they couldn’t disclose the macro to me due to confidentiality issues, thus I have to be really vague here, I’m sorry if it’s frustrating to you and I understand how frustrating it can be.

#### XanderTheNotSoAwesome

##### New Member
Will give those help above a try and let you know how it goes — and as usual, thank you so much for going out of your way to help!

#### XanderTheNotSoAwesome

##### New Member
Thanks for helping out with the codes! I managed to get it settled! Much appreciated. You are awesome

Replies
0
Views
37
Replies
5
Views
49
Replies
1
Views
303
Replies
16
Views
80
Replies
4
Views
81

1,133,532
Messages
5,659,368
Members
418,499
Latest member
mbcmel

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

### Which adblocker are you using?

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back