Colour results cell based on cell colour of Min( )

[EricofPendom]

Hi Folks,

I have 5 companies that supply a figure for an item and each of the companies has a specific colour for their column of data in the sheet. I have a column to the right of these that returns the Min( ) of these five figures and I would like to automatically colour the cell the same as the company colour using VBA. I can't figure out how to capture the range from the min( ) statement and then get the colour of the cell in question.

I have attached a sample showing the result I require.

Any help would be most appreciated.

Thanks in advance

Eric...

[wakeupcall]

Hi,

Have a look at this

Sub Colour_Value()

Dim Cell As Range

With ActiveSheet

Range("F2").Formula = WorksheetFunction.Min(Range("A2:E2"))
Range("F2:F9").FillDown

For Each Cell In Range("F2:F9")

If Cell.Value = Cells((Cell.Row), 1) Then
Cell.Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
End If

If Cell.Value = Cells((Cell.Row), 2) Then
Cell.Select
   With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
End If
If Cell.Value = Cells((Cell.Row), 3) Then
Cell.Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
End If

If Cell.Value = Cells((Cell.Row), 4) = True Then
Cell.Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark2
        .TintAndShade = -9.99786370433668E-02
        .PatternTintAndShade = 0
    End With
End If

If Cell.Value = Cells((Cell.Row), 5) = True Then
Cell.Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
End If

Next Cell

End With
End Sub

If your the length of the columns change with every run, you should replace this

 ("F2:F9")

with this

("F2:F" & .UsedRange.Rows.Count)

[EricofPendom]

Thanks Wakeupcall that works great.