VBA code

[The Idea Dude]

What code would do the following?

There are 5 numbers in different cells (These numbers can change)

A1=2,
A2=6,
A3=9,
A4=35,
A5=3

I need to allocate one colour to the highest number, a different colour to the next highest and so on.

Any suggestions?
This message was edited by The Idea Dude on 2002-09-11 03:49

 

[ChrisUK]

Ok, not the neatest idea but one you can work with. This works nicely with values in the cells upto 255, over that and the VB errors as the colour 256 is not available so you'd need to do some maths (divide the value by 255) if you wanted to go this way. I recon you could put the colour bit in a loop as well to make the macro more compact.

Have you also discounted conditional formating ? This would only work for 4 cells (one background) would always be white)

anyway,s hope this helps you

Range("A1:A5").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A1").Select
With Selection.Interior
.ColorIndex = Range("A1").Value
.Pattern = xlSolid
End With
Range("A2").Select
With Selection.Interior
.ColorIndex = Range("A2").Value
.Pattern = xlSolid
End With
Range("A3").Select
With Selection.Interior
.ColorIndex = Range("A3").Value
.Pattern = xlSolid
End With
Range("A4").Select
With Selection.Interior
.ColorIndex = Range("A4").Value
.Pattern = xlSolid
End With
Range("A5").Select
With Selection.Interior
.ColorIndex = Range("A5").Value
.Pattern = xlSolid
End With

 

[The Idea Dude]

Thanks for the reply Chris. I am unable to change the location of the data (sort) because the cells are results of formulas.

Any other ideas?

 

[Iain Lewis]

How about this code :

Dim myCount As Integer
Dim myRan As String

Sub aaa()
myCount = 1
Do Until myCount = 6
myRan = WorksheetFunction.Large(Range("A1:A5"), myCount)
Range("A1:A5").Find(myRan, LookAt:=xlWhole).Select
Selection.Interior.ColorIndex = myCount
myCount = myCount + 1
Loop
End Sub

At the moment it doesn't allow you to specify the colour, but I'm sure it can be changed if reqiured.

BTW - it ignores duplicated numbers, so may need more work there.

Iain
This message was edited by Iain Lewis on 2002-09-11 04:15

 

[Andrew Poulsom]

Try this:

Sub Test()
    Dim Rng As Range
    Dim c As Range
    Dim x As Long
    Set Rng = Range("A1:A5")
    For Each c In Rng
        x = Application.Rank(c.Value, Rng)
        Select Case x
            Case 1: c.Font.ColorIndex = 3
            Case 2: c.Font.ColorIndex = 4
            Case 3: c.Font.ColorIndex = 5
            Case 4: c.Font.ColorIndex = 6
            Case 5: c.Font.ColorIndex = 7
        End Select
    Next c
End Sub

 

[ChrisUK]

OK, try this instead

Sub sortit()

Dim myarray(5)

'Copy cells to an array
For x = 1 To 5
myarray(x) = Cells(x, 1)
Next

'Sort the array
For x = 1 To 5
For y = 1 To x - 1
If myarray(x) < myarray Then
t = myarray(x)
myarray(x) = myarray
myarray = t
End If
Next
Next

mcol = 15
'Colour cells
For x = 1 To 5
For y = 1 To 5
If myarray(x) = Cells(y, 1) Then
Cells(y, 1).Select
With Selection.Interior
.ColorIndex = mycol
.Pattern = xlSolid
End With
mycol = mycol + 1
Exit For
End If
Next
Next

x = 1

End Sub

 

[ChrisUK]

I like Andrews much better, I can't see any help for a "rank" method mind you!!

 

[The Idea Dude]

Thanks every one for your help,

I tried Andrews code and it worked a charm so I didn't try the other ones, but thanks anyway! If you are keen, I have another question on the board (text wrap) that I am stuck with.

Thanks again

 

[Andrew Poulsom]

ChrisUK,

Rank is a worksheet function. I find it very useful for dynamically sorting data (eg for printing). I put in a column to rank the data, then in another column use Index, Match and Large (or Small) to reference and sort the original data.

 

[Jay Petrulis]

On 2002-09-11 04:24, Andrew Poulsom wrote:
Try this:

Sub Test()
    Dim Rng As Range
    Dim c As Range
    Dim x As Long
    Set Rng = Range("A1:A5")
    For Each c In Rng
        x = Application.Rank(c.Value, Rng)
        Select Case x
            Case 1: c.Font.ColorIndex = 3
            Case 2: c.Font.ColorIndex = 4
            Case 3: c.Font.ColorIndex = 5
            Case 4: c.Font.ColorIndex = 6
            Case 5: c.Font.ColorIndex = 7
        End Select
    Next c
End Sub

Hi Andrew,

Nice job here. Kudos.

If the color scheme has some pattern, as in your example, it can be shortened a bit to the following...

<pre>Sub Test()
Dim Rng As Range
Dim c As Range
Dim x As Long

Set Rng = Range("A1:A5")
For Each c In Rng
x = Application.Rank(c.Value, Rng)
c.Font.ColorIndex = x + 2
Next c
End Sub</pre>