CODEWITHSUNDEEP
vbaexcelcopy-paste
Stephopolis
Stephopolis

Reputation: 1795

Excel: Check value and copy color from a cell

I feel like this question has been asked before, but I am just not really understanding the solutions. I would like to know how to check the values of some cells and copy the colors of those that match to another cell. I have a worksheet that looks like this: 

   A        B           C       D               E               F
 1 Type     Location    Cell    PairType        PairLocation    PairCell
 2 EX3      1           A1      EX2             1               F3
 3 EX4      1           B2      EX3             1               G3
 4 EX2      1           F3      EX3             1               A1

Some of the values in A, B and C have different colors to mark them as special (background colors, not font colors). I need to take the values from column D, find the match in A and then if/when I find a match, copy the background colors from A, B and C to the background of D, E and F. If I find a D to A match (like row 2, column D to row 4, column A) then the E/F values will also match the B/C values (as shown above), so I don't have to worry about overwriting any values. I am not really fluent in Excel-ese so when I read a solution like this: 

Function BGCol(MRow As Integer, MCol As Integer)  As Integer
   BGCol = Cells(MRow, MCol).Interior.ColorIndex  
End Function

I am not really sure what I am getting myself into. Can anyone offer a solution and an explaination?

Upvotes: 0

Views: 10965

Answers (2)

Scott Holtzman
Scott Holtzman

Reputation: 27259

This should work. It could be made more efficient, but it will definitely get you started.

Place this in a standard module and run the code (F5 or F8 to step through it). Let me know if you need more guidance.

Sub CheckColors()

Dim rng As Range

For Each cel In Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row)

    Set rng = Columns(1).Find(cel, lookat:=xlWhole)

    If Not rng Is Nothing Then

        cel.Interior.ColorIndex = rng.Interior.ColorIndex
        cel.Offset(, 1).InteriorColorIndex = rng.Offset(, 1).Interior.ColorIndex
        cel.Offset(, 2).InteriorColorIndex = rng.Offset(, 2).Interior.ColorIndex

    End If

Next

End Sub

Upvotes: 0

Vinny Roe
Vinny Roe

Reputation: 901

Sub ReColour()

Dim rStart As Range, lRow1 As Long, lRow2 As Long, lRows As Long, sFind As String

Set rStart = Sheet1.Range("A1")
lRows = rStart.Offset(65000, 0).End(xlUp).Row - rStart.Row

For lRow1 = 1 To lRows
    sFind = rStart.Offset(lRow1, 3).Value
    For lRow2 = 1 To lRows
        If rStart.Offset(lRow2, 0).Value = sFind Then
            rStart.Offset(lRow1, 3).Interior.ColorIndex = rStart.Offset(lRow2, 0).Interior.ColorIndex
            rStart.Offset(lRow1, 4).Interior.ColorIndex = rStart.Offset(lRow2, 1).Interior.ColorIndex
            rStart.Offset(lRow1, 5).Interior.ColorIndex = rStart.Offset(lRow2, 2).Interior.ColorIndex
            Exit For
        End If
    Next
Next
End Sub

Sorry no time to explain right now, but I think this'll do it. You should really use something better than magic column numbers 3,4,5 etc but this is a quickndirty solution.

Upvotes: 1

Related Questions