S
Sam Harman
Hi Ron and thanks for your last post....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 which combined the date and time fields but can I also 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? The columns are not always adjacent.
As always your consideration and help is much appreciated
Regards
Sam
------------------------------------------------------------------------------
This is the code you originally provided and which I am using:
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
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 which combined the date and time fields but can I also 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? The columns are not always adjacent.
As always your consideration and help is much appreciated
Regards
Sam
------------------------------------------------------------------------------
This is the code you originally provided and which I am using:
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
