Cell colour change to match that to its left

[callummcgrath]

Hey everyone,

So as the title suggests, I would like a way whereby a cell automatically changes to the colour of the cell to it's left (or to a specific cell). So that when I change the colour of cell a1 for example, it will automatically change the colour of cells b1, c1 & d1.

I have attached an example document to help explain my point. As the first column may be merged and therefore I want all the cells to its right to be the same colour as it.

All ideas welcome, thanks!

Callum

[Stormin']

There is no worksheet event that triggers on a format change (e.g. background fill). However, the code below achieves what you want, you just need to find a worksheet event that you are happy with.

Option Explicit

Sub t()

    Dim rColA As Range
    Dim rColB As Range
    Dim rColC As Range
    Dim rCell As Range
    Dim i     As Integer
    
    With ActiveSheet
        Set rColA = Intersect(Columns("A"), .UsedRange)
        Set rColB = rColA.Offset(0, 1)
        Set rColC = rColA.Offset(0, 2)
    End With
    
    For i = 1 To rColA.Rows.Count
        Set rCell = rColA.Cells(i, 1)
        If rCell.Interior.Pattern <> xlNone Then
            rColB.Cells(i, 1).Interior.Color = rCell.Interior.Color
            rColC.Cells(i, 1).Interior.Color = rCell.Interior.Color
        End If
        rColB.Cells(i, 1).Interior.Pattern = rCell.Interior.Pattern
        rColC.Cells(i, 1).Interior.Pattern = rCell.Interior.Pattern
    Next i
    
End Sub

[callummcgrath]

Thanks Stormin! That worked perfectly!

I'm now just trying to make it copy the colour across to column AU - edited as follows;


'Option Explicit
Sub Colour_Change()
Dim rColA As Range
Dim rColB As Range
Dim rColC As Range
Dim rColD As Range
Dim rColE As Range
Dim rColF As Range
Dim rColG As Range
Dim rColH As Range
Dim rColI As Range
Dim rColJ As Range
Dim rColK As Range
Dim rColL As Range
Dim rColM As Range
Dim rColN As Range
Dim rColO As Range
Dim rColP As Range
Dim rColQ As Range
Dim rColR As Range
Dim rColS As Range
Dim rColT As Range
Dim rColU As Range
Dim rColV As Range
Dim rColW As Range
Dim rColX As Range
Dim rColY As Range
Dim rColZ As Range
Dim rColAA As Range
Dim rColAB As Range
Dim rColAC As Range
Dim rColAD As Range
Dim rColAE As Range
Dim rColAF As Range
Dim rColAG As Range
Dim rColAH As Range
Dim rColAI As Range
Dim rColAJ As Range
Dim rColAK As Range
Dim rColAL As Range
Dim rColAM As Range
Dim rColAN As Range
Dim rColAO As Range
Dim rColAP As Range
Dim rColAQ As Range
Dim rColAR As Range
Dim rColAS As Range
Dim rColAT As Range
Dim rColAU As Range
Dim rCell As Range
Dim i As Integer

With ActiveSheet
Set rColA = Intersect(Columns("A"), .UsedRange)
Set rColB = rColA.Offset(0, 1)
Set rColC = rColA.Offset(0, 2)
Set rColD = rColA.Offset(0, 3)
Set rColE = rColA.Offset(0, 4)
Set rColF = rColA.Offset(0, 5)
Set rColG = rColA.Offset(0, 6)
Set rColH = rColA.Offset(0, 7)
Set rColI = rColA.Offset(0, 8)
Set rColJ = rColA.Offset(0, 9)
Set rColK = rColA.Offset(0, 10)
Set rColL = rColA.Offset(0, 11)
Set rColM = rColA.Offset(0, 12)
Set rColN = rColA.Offset(0, 13)
Set rColO = rColA.Offset(0, 14)
Set rColP = rColA.Offset(0, 15)
Set rColQ = rColA.Offset(0, 16)
Set rColR = rColA.Offset(0, 17)
Set rColS = rColA.Offset(0, 18)
Set rColT = rColA.Offset(0, 19)
Set rColU = rColA.Offset(0, 20)
Set rColV = rColA.Offset(0, 21)
Set rColW = rColA.Offset(0, 22)
Set rColX = rColA.Offset(0, 23)
Set rColY = rColA.Offset(0, 24)
Set rColZ = rColA.Offset(0, 25)
Set rColAA = rColA.Offset(0, 26)
Set rColAB = rColA.Offset(0, 27)
Set rColAC = rColA.Offset(0, 28)
Set rColAD = rColA.Offset(0, 29)
Set rColAE = rColA.Offset(0, 30)
Set rColAF = rColA.Offset(0, 31)
Set rColAG = rColA.Offset(0, 32)
Set rColAH = rColA.Offset(0, 33)
Set rColAI = rColA.Offset(0, 34)
Set rColAJ = rColA.Offset(0, 35)
Set rColAK = rColA.Offset(0, 36)
Set rColAL = rColA.Offset(0, 37)
Set rColAM = rColA.Offset(0, 38)
Set rColAN = rColA.Offset(0, 39)
Set rColAO = rColA.Offset(0, 40)
Set rColAP = rColA.Offset(0, 41)
Set rColAQ = rColA.Offset(0, 42)
Set rColAR = rColA.Offset(0, 43)
Set rColAS = rColA.Offset(0, 44)
Set rColAT = rColA.Offset(0, 45)
Set rColAU = rColA.Offset(0, 46)
End With

For i = 1 To rColA.Rows.Count
Set rCell = rColA.Cells(i, 1)
If rCell.Interior.Pattern <> xlNone Then
rColB.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColC.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColD.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColE.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColF.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColG.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColH.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColI.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColJ.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColK.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColL.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColM.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColN.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColO.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColP.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColQ.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColR.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColS.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColT.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColU.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColV.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColW.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColX.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColY.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColZ.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAA.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAB.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAC.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAD.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAE.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAF.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAG.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAH.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAI.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAJ.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAK.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAL.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAM.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAN.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAO.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAP.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAQ.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAR.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAS.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAT.Cells(i, 1).Interior.Color = rCell.Interior.Color
rColAU.Cells(i, 1).Interior.Color = rCell.Interior.Color
End If
rColB.Cells(i, 1).Interior.Pattern = rCell.Interior.Pattern
rColB.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColC.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColD.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColE.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColF.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColG.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColH.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColI.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColJ.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColK.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColL.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColM.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColN.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColO.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColP.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColQ.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColR.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColS.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColT.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColU.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColV.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColW.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColX.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColY.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColZ.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAA.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAB.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAC.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAD.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAE.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAF.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAG.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAH.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAI.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAJ.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAK.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAL.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAM.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAN.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAO.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAP.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAQ.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAR.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAS.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAT.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
rColAU.Cells(i, 1).Interior.Color = rCell.Interior.Pattern
Next i

End Sub

However, all the cells just come back black, what have I missed?

lso, is there a simpler way to write this out i.e. rColA:AU.Cells(i, 1).Interior.Color = rCell.Interior.Pattern ? Not the end of the world if not as I've already written it all out now

Thanks

Callum

[Stormin']

Jeez, props to you for writing that all out. Here is a smaller version of that code if you wish to do loads of columns with no gaps

Sub t()

    Dim rColA As Range
    Dim rColB As Range
    Dim rSrc  As Range
    Dim rDst  As Range
    Dim i     As Long
    Dim x     As Long
    
    'First column
    Set rColA = Columns("A")
    
    'Final column
    Set rColB = Columns("AU")
    
    
    'No need to edit below this line
    x = rColB.Column - (rColA.Column - 1)
    Set rColA = Intersect(rColA, ActiveSheet.UsedRange)
    For i = 1 To rColA.Rows.Count
        Set rSrc = rColA.Cells(i, 1)
        Set rDst = Range(rSrc.Offset(0, 1), rSrc.Offset(0, x - 1))
        If rSrc.Interior.Pattern <> xlNone Then
            rDst.Interior.Color = rSrc.Interior.Color
        End If
        rDst.Interior.Pattern = rSrc.Interior.Pattern
    Next i
    
End Sub

P.S. Your cells came up black because of a copy/paste mistake when you wrote the lines

rColAU.Cells(i, 1).Interior.Color = rCell.Interior.Pattern

[callummcgrath]

Stormin'

It's obvious now you've said it! Thanks a lot, that worked perfectly, you're amazing!

Callum

[Stormin']

No worries, always willing to help someone from my home town

---

If that takes care of your original question, please select Thread Tools from the menu link above to mark this thread as SOLVED.
To say thanks to the user(s) who contributed towards the solution, you can use the "Add Reputation" button on their helpful post(s).
Thanks!