S
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
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