Attn Ron Rosenfeld

[Sam Harman]

Hi Ron, I hope you are well and as always thanks for the help you have
provided to me.

However it has been a couple of weeks now since I asked for your help
and I think it it time for another request LOL

This is a small request and hopefully just a minor tweak to one of the
macros you have previously provided......

It is the macro that highlights the top four values which then
highlights the top value with a background colour of yellow and the
remaining values with a background colour of green as per below:

----------------------------------------------------------------------------------------------------

Sub Color2ORNew()
Dim rTimes As Range, rValues As Range, c As Range
Dim APOffset As Long
Dim tTimes() As Variant, dPVals() As Double
Dim collTime As Collection, collColU As Collection
Dim bLowest As Boolean
Dim i As Long, j As Long

On Error Resume Next

Set rTimes = Application.InputBox(Prompt:="Select the Times", _
Default:=Selection.Address, Type:=8)
If rTimes Is Nothing Then Exit Sub

Set rValues = Application.InputBox("Select a cell in the column of
Values", Type:=8)
If rValues Is Nothing Then Exit Sub

On Error GoTo 0

bLowest = IIf(MsgBox("Lowest 4?", vbYesNo) = vbYes, True, False)

APOffset = rValues.Column - rTimes.Column

'Unique list of times
Set collTime = New Collection
On Error Resume Next
For Each c In rTimes
collTime.Add Item:=c.Value, Key:=CStr(c.Value)
Next c
On Error GoTo 0

ReDim tTimes(0 To collTime.Count - 1, 0 To 2)
For i = 0 To collTime.Count - 1
tTimes(i, 0) = collTime(i + 1)
Next i

'unique list of rValues values for each time
For i = 0 To UBound(tTimes, 1)
Set collColU = New Collection
On Error Resume Next
For Each c In rTimes
If c.Value = tTimes(i, 0) Then
With c.Offset(columnoffset:=APOffset)
If bLowest = True Then collColU.Add
Item:=CDbl(.Text), Key:=CStr(.Text)
If bLowest = False And .Value <> 0 Then
collColU.Add Item:=CDbl(.Text), Key:=CStr(.Text)
End With
End If
Next c
On Error GoTo 0
If collColU.Count > 0 Then
ReDim dPVals(0 To collColU.Count - 1)
For j = 0 To UBound(dPVals)
dPVals(j) = collColU(j + 1)
Next j
End If
With WorksheetFunction
If bLowest Then
tTimes(i, 1) = .Small(dPVals, .Min(UBound(dPVals) + 1,
2))
tTimes(i, 2) = .Min(dPVals)
Else
tTimes(i, 1) = .Large(dPVals, .Min(UBound(dPVals) + 1,
2))
tTimes(i, 2) = .Max(dPVals)
End If

End With
Next i

'color the cells
For i = 0 To UBound(tTimes, 1)
For Each c In rTimes
If c.Value = tTimes(i, 0) Then
With c.Offset(columnoffset:=APOffset)
If bLowest = False Then
Select Case CDbl(.Text)
Case Is = tTimes(i, 2)
.Interior.Color = vbYellow
Case Is >= tTimes(i, 1)
.Interior.Color = vbGreen
Case Else
.Interior.Color = xlNone
End Select
ElseIf bLowest = True Then
Select Case CDbl(.Text)
Case Is = tTimes(i, 2)
.Interior.Color = vbYellow
Case Is <= tTimes(i, 1)
.Interior.Color = vbGreen
Case Else
.Interior.Color = xlNone
End Select
End If
End With
End If
Next c
Next i
End Sub

----------------------------------------------------------------------------------------------------

The question I have is this....is it possible once the highlighted
values have been selected and the cell background colour applied to
make the text red?

Thanks in advance

Cheers

Sam

 

[Don Guillett]

In this part add a line
        End With

            End If
c.font.colorindex=3

        Next c
    Next i

 

[Sam Harman]

It's just a matter of adding a line to set the font color after the line that sets the fill (interior) color (and also resets it back to black if there is not going to be shading):

Select Case CDbl(.Text)
Case Is = tTimes(i, 2)
.Interior.Color = vbYellow
.Font.Color = vbRed
Case Is >= tTimes(i, 1)
.Interior.Color = vbGreen
.Font.Color = vbRed
Case Else
.Interior.Color = xlNone
.Font.Color = vbBlack
End Select
ElseIf bLowest = True Then
Select Case CDbl(.Text)
Case Is = tTimes(i, 2)
.Interior.Color = vbYellow
.Font.Color = vbRed
Case Is <= tTimes(i, 1)
.Interior.Color = vbGreen
.Font.Color = vbRed
Case Else
.Interior.Color = xlNone
.Font.Color = vbBlack
End Select

Thank you very much once again

Cheers

Sam

 

[Sam Harman]

In this part add a line
        End With

Thanks very much

Cheers

Sam

 

[Sam Harman]

Hi Ron, I seem to have lost my initial post so am reposting here in
case you didnt see it...

Hi Ron, hope you are well

I have another query which I hope you can help with....

It is relation to the Master Table setup below but this time with a
twist lol

In the master table i have recorded where each competition was and the
result as follows:

Date Time Location Dog Position

01 Mar 2011 10.00 Location A Dog A 1
01 Mar 2010 10.00 Location A Dog A 4
01 Mar 2009 10.00 Location A Dog A FTC

The results of the competition only ever go from 1 - 40 but there are
also alpha results such as failed to complete would be FTC

What I would like to do if possible have a column in the main
worksheet that shows how the dog performed the last times it was at
that same competition.

So in the example above, the cell in the main spreadsheet would be
populated as follows: FTC-4-1 with a hyphen between each result...

Also as before I would add in the >dates forumula so that for the next
comp it would show performance only up to that date and not update
previous entries based on new data

Finally, when I need to update the range in the master table as I add
new data is it possible to automate that process or do I need to
individually update the name ranges to extend to new data when added?

Hope that all makes sense and thanks again for all your help.....it is
really appreciated

Kind regards


Sam

 

[Sam Harman]

Hi Ron, I did see your response of 8/10 and thanked you for it...it
worked great

This is a slightly different query as below which I hope you can help
with. This one is about showing results in a different format.

I hope I have explained it alright below...

Thansk in advance

Sam

 

[Sam Harman]

Hi Ron, no problem.

Enjoy your trip

Cheers

Sam