Attn Ron Rosenfeld

[Sam Harman]

Hi Ron, not sure if you have seen this so posting again as disappeared
from my news reader....

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

Hi Ron and thanks that worked a treat.

Sorry it took so long to thank you but I have been working away and
not had a chance to get back on the newsgroup...

I have one more small question. Do you remember you wrote some code
which highlighted the top three values as follows. Top value
highlighted yellow and red font, 2nd top highlighted green and red
font and third top highlighted green and red font (See below for code)

My question is this, I can now do this for retrospective dates using
your code above by combining the date and time columns but can I do it
for more than one column at a time. For example, I have 10 columns
which I would like to apply the top three macro to and currently have
to do the same thing for each column. I.e select the times, then
select a value in the column. Is it all possible to amend the code so
that when I select a time, i can then select more than one column for
the macro to be run on?

As always your consideration and help is much appreciated

Regards

Sam

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

Sub Color3SPRNew()
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, collColQ 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 collColQ = 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 collColQ.Add
Item:=CDbl(.text), Key:=CStr(.text)
If bLowest = False And .Value <> 0 Then
collColQ.Add Item:=CDbl(.text), Key:=CStr(.text)
End With
End If
Next c
On Error GoTo 0
If collColQ.Count > 0 Then
ReDim dPVals(0 To collColQ.Count - 1)
For j = 0 To UBound(dPVals)
dPVals(j) = collColQ(j + 1)
Next j
End If
With WorksheetFunction
If bLowest Then
tTimes(i, 1) = .Small(dPVals, .Min(UBound(dPVals) + 1,
3))
tTimes(i, 2) = .Min(dPVals)
Else
tTimes(i, 1) = .Large(dPVals, .Min(UBound(dPVals) + 1,
3))
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
.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
End If
End With
End If
Next c
Next i
End Sub

 

[Ron Rosenfeld]

Hi Ron, not sure if you have seen this so posting again as disappeared
from my news reader....

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

Hi Ron and thanks that worked a treat.

Sorry it took so long to thank you but I have been working away and
not had a chance to get back on the newsgroup...

I have one more small question. Do you remember you wrote some code
which highlighted the top three values as follows. Top value
highlighted yellow and red font, 2nd top highlighted green and red
font and third top highlighted green and red font (See below for code)

My question is this, I can now do this for retrospective dates using
your code above by combining the date and time columns but can I do it
for more than one column at a time. For example, I have 10 columns
which I would like to apply the top three macro to and currently have
to do the same thing for each column. I.e select the times, then
select a value in the column. Is it all possible to amend the code so
that when I select a time, i can then select more than one column for
the macro to be run on?

As always your consideration and help is much appreciated

Regards

Sam

See response in other thread.