Copy a range of coloured cells based on their position

[Stigdu]

My wife's working on a spreadsheet, and wants to do something which I'm hoping conditional formatting can sort for me, but we're both stuck.

It's basically a calendar, and 2 of the rows (let's call them row A for preparation date and row D for work start date) need to work in conjunction.

So if she has coloured cells from D20-D23, she wants A17-A19 to automatically populate with coloured cells.It specifically has to be 3 cells in Row A that become coloured, the last of which will be the one before the first cell to be coloured in on Row D.

Phew! Hope that makes sense. Is this possible with conditional formatting, or is it too complicated for that? I also looked at the OFFSET command, but that seemed to return values rather than just copy blank cell colours.

Thanks for any help.

 

[dpavlina]

Re: Help needed to copy a range of coloured cells based on their position

Is she manually coloring the cells in D20-D23, or are they based on some conditional formatting? Also, is the relative positioning always the same?

 

[Stigdu]

Re: Help needed to copy a range of coloured cells based on their position

She manually colours the cells in, and yes, the relative position is always the same.

 

[dpavlina]

Re: Help needed to copy a range of coloured cells based on their position

She manually colours the cells in, and yes, the relative position is always the same.

The code below will work for your request. Be sure to select the cell that contains the first color you want copied. The macro will then copy the color of that cell and the three below it to a relative position three columns left and three rows up, per your example.

Sub ColorTransfer()


' This routine will take the color from the current cell and the three below it and copy those colors to the cells three columns to the left and three rows up
' Be sure to select the starting cell before executing this code as there is no error checking currently built in.




    Dim row, col
    
    For i = 1 To 4
        col = ActiveCell.Column
        row = ActiveCell.row
        ActiveSheet.Cells(row, col).Select
        With Selection.Interior
            currentcolor = .ColorIndex
        End With
        newcol = col - 3
        newrow = row - 3
        ActiveSheet.Cells(newrow, newcol).Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = alAutomatic
            .ColorIndex = currentcolor
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        
        row = row + 1
        ActiveSheet.Cells(row, col).Select
    Next i
    
End Sub

I hope this is what you were looking for.

 

[Stigdu]

Thank you very much!