FAO Ron Rosenfeld

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
 
R

Ron Rosenfeld

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
Click to expand...

It should be fairly simple to do that. I would just write a sub that allows you to select all your columns, then that sub would sequentially call the second sub, which would be changed slightly to use the arguments provided by the first, rather than the InputBox, for the source data.

Are there multiple columns of date/times and a single column of numbers? Or are there multiple pairs of date/time - Numbers to be selected?
 
S

Sam Harman

It should be fairly simple to do that. I would just write a sub that allows you to select all your columns, then that sub would sequentially call the second sub, which would be changed slightly to use the arguments provided by the first, rather than the InputBox, for the source data.

Are there multiple columns of date/times and a single column of numbers? Or are there multiple pairs of date/time - Numbers to be selected?
Click to expand...

Hi Ron and thanks for the prompt reply....

I have uploaded a file to sky drive which I hope you can get a chance
to look at and hopefully it will explain better what I am hoping to
achieve.

https://skydrive.live.com/view.aspx?cid=CB2CB4829572A60A&resid=CB2CB4829572A60A!290

Thanks again


Kind regards

Sam
 
R

Ron Rosenfeld

Hi Ron and thanks for the prompt reply....

I have uploaded a file to sky drive which I hope you can get a chance
to look at and hopefully it will explain better what I am hoping to
achieve.

https://skydrive.live.com/view.aspx?cid=CB2CB4829572A60A&resid=CB2CB4829572A60A!290

Thanks again


Kind regards

Sam
Click to expand...

Sam,

Try this:

and note the NumToColor constant at line 4 which should make it simpler to make that change in how many that you wrote about.
Since all your values are either real numbers or blanks, we don't have to do data conversions so should avoid the "blanks causing errors" you wrote about.

============================================
Option Explicit
Sub ColorNew()
Dim rTimes As Range, rValues As Range, c As Range
Const NumToColor As Long = 4
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, k 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 One (1) cell in each column of Values ", Type:=8)
If rValues Is Nothing Then Exit Sub

On Error GoTo 0

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

ReDim APOffset(0 To rValues.Count - 1)
i = 0
For Each c In rValues
APOffset(i) = c.Column - rTimes.Column
i = i + 1
Next c

'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

Application.ScreenUpdating = False
For k = 0 To UBound(APOffset)
'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(k))
If bLowest = True Then collColQ.Add Item:=.Value, Key:=CStr(.Text)
If bLowest = False And .Value <> 0 Then collColQ.Add Item:=.Value, 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, NumToColor))
tTimes(i, 2) = .Min(dPVals)
Else
tTimes(i, 1) = .Large(dPVals, .Min(UBound(dPVals) + 1, NumToColor))
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(k))
If bLowest = False Then
'Select Case CDbl(.Text)
Select Case .Value
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)
Select Case .Value
Case Is = ""
.Interior.Color = xlNone
.Font.Color = vbBlack
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
Next k
Application.ScreenUpdating = True
End Sub
===========================================
 
R

Ron Rosenfeld

Hi Ron, thank you so much for your revised code...it works a
treat...:)

I now have another question regarding counting cells that have been
formatted and conditionally formatted and wondered if you know of a
solution?

I have placed the file on my skydrive

https://skydrive.live.com/view.aspx?cid=CB2CB4829572A60A&resid=CB2CB4829572A60A!291

Thanks in advance

Regards


Sam
Click to expand...

For formatted cells it is fairly straightforward. See http://www.cpearson.com/excel/colors.aspx for a discussion.

For conditionally formatted cells, you need to test whether the format condition applies to the cell. So an algorithm might look like:

1. Is the cell conditionally formatted; if not --> Exit
2. Obtain the conditional format functions from the CF Object.
3. Test to see if any of the conditions apply, and count 1 if they do.
 
S

Sam Harman

For formatted cells it is fairly straightforward. See http://www.cpearson.com/excel/colors.aspx for a discussion.

For conditionally formatted cells, you need to test whether the format condition applies to the cell. So an algorithm might look like:

1. Is the cell conditionally formatted; if not --> Exit
2. Obtain the conditional format functions from the CF Object.
3. Test to see if any of the conditions apply, and count 1 if they do.
Click to expand...

Thanks again Ron, I have tried all of the methods on the net,
including chip pearson, ozgrid, choobah, xlsdynamic atc but cannot
seem to get any of them to work properly.....really frustrating...

I just wondered if there was a simple macro that would do the trick?

Cheers

Sam
 
R

Ron Rosenfeld

Thanks again Ron, I have tried all of the methods on the net,
including chip pearson, ozgrid, choobah, xlsdynamic atc but cannot
seem to get any of them to work properly.....really frustrating...

I just wondered if there was a simple macro that would do the trick?

Cheers

Sam
Click to expand...

Sam,

When you ask to test if there is some kind of formatting applied to a cell, it can get real complicated as there are my types of formatting that can be applied to a cell. There are different styles of borders, interior shading and colors, font colors, sizes, characteristics, etc. If you want a "simple" macro, you must provide "simple" conditions. Instead of testing whether a cell "has been formatted", you might ask, instead, is there an interior color? No interior color is the baseline; so anything with an interior color could be counted. To test that is fairly simple:

For example:

Function HasInteriorColor(rg As Range) As Boolean
HasInteriorColor = (rg.Interior.ColorIndex <> xlColorIndexNone)
End Function

You could also test for font color being other than black, or test for either:

Function IsFormatted(rg As Range) As Boolean
IsFormatted = (rg.Interior.ColorIndex <> xlColorIndexNone) Or _
(rg.Font.Color <> vbBlack)
End Function

(Or more understandably, but longer:

Function IsFormatted(rg As Range) As Boolean
If rg.Interior.ColorIndex <> xlColorIndexNone Or _
rg.Font.Color <> vbBlack Then
IsFormatted = True
Else
IsFormatted = False
End If
End Function

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

However, the above will not apply to conditional formatting. In order to determine if a cell has been formatted according to a conditional formatting procedure, you need to know all of the conditional formatting that applies to the particular cell; then you test the cell to see if it meets those conditions. In your workbook, columns H and part of I are formatted if their values are from 0.25 to 0.33. So you will need to test the cells to see if that obtains. If the .25, .33, and the "between" operation will stay constant, you can hardcode it. If not, you will have to obtain the appropriate values from the formatcondition property for each cell.

Since you offered a worksheet as an example, I will assume that a cell has been manually formatted if it has some interior color;
that the format condition will always be a "between" operator,
but that you might change the values from 0.25 / 0.33 to some other value.


Obviously this short User Defined Function cannot account for all possible formats and all possible conditional formats, but it might do for your purposes.

You enter it into a regular module as you did with the macros (Sub).

You use it by entering a formula like:

J2: =CountFmt(D2:I2)

and fill down as far as possible.

I would suggest custom formatting the cells in column J to

Format/Cells/Custom Type: 0;0;; so as to render the 0's blank, as you have in the sample sheet you provided. I have also assumed that J10 on that sheet should be a 4 and not a blank.

================================
Option Explicit
Function CountFmt(rg As Range) As Long
Dim c As Range
Dim t As Long
Dim fc As FormatCondition
Dim c1 As Double, c2 As Double
For Each c In rg
If c.Interior.ColorIndex <> xlColorIndexNone Then
t = t + 1
ElseIf c.FormatConditions.Count > 0 Then
Set fc = c.FormatConditions(1)
If fc.Operator <> xlBetween Then
MsgBox ("Conditional Format cannot be processed")
Exit Function
End If
c1 = Evaluate(fc.Formula1)
c2 = Evaluate(fc.Formula2)
If c.Value >= c1 And c.Value <= c2 Then
t = t + 1
End If
End If
Next c
CountFmt = t
End Function
========================================
 
R

Ron Rosenfeld

When you ask to test if there is some kind of formatting applied to a cell, it can get real complicated as there are my types of formatting that can be applied to a cell.
Click to expand...

Typo: The above should read ... many types of formatting ...

Also, in the UDF I provided, I also assumed, as is the case in the sample worksheet you provided, that only a single conditional formatting rule might apply to any cell; so I am only checking on the "first".
 
S

Stan Brown

Maybe you could use subject lines that actually describe your
problem. Ron's not the only one here who might help.

If you actually want to communicate with one person and only that
person, there's email, you know.
 
S

Sam Harman

Maybe you could use subject lines that actually describe your
problem. Ron's not the only one here who might help.

If you actually want to communicate with one person and only that
person, there's email, you know.
Click to expand...

Sorry Stan but I have been posting with proper thread titles and Ron
has been very helpful in his responses.

My ISP does not keep headers for long and that is why I titled my
recent post FAO ROn so that it would hopefully attract his attention
as I am sure he doesnt read every thread on this newgroup.

It is not an exclusive invite for Ron only to help so feel free to
contribute....but as it was tweaks to already provided modules I
thought it best that I ask Ron direct.

Also I am not sure of the merits of postin an e-mail on here that is
why I have not conversed via email.

Regards

Sam
 
S

Sam Harman

Sorry Stan but I have been posting with proper thread titles and Ron
has been very helpful in his responses.

My ISP does not keep headers for long and that is why I titled my
recent post FAO ROn so that it would hopefully attract his attention
as I am sure he doesnt read every thread on this newgroup.

It is not an exclusive invite for Ron only to help so feel free to
contribute....but as it was tweaks to already provided modules I
thought it best that I ask Ron direct.

Also I am not sure of the merits of postin an e-mail on here that is
why I have not conversed via email.

Regards

Sam
Click to expand...


Following on from that last post I have updated my spreadsheet to try
and explain better what I am trying to do.

Ron I tried your formula but could not get it to work and that is
probably largely because I did not explain myself properly - apologies
for that..

https://skydrive.live.com/view.aspx?cid=CB2CB4829572A60A&resid=CB2CB4829572A60A!292

Stan if you can add anything to themix it would be much appreciated.

Thanks as always Ron

Cheers

Sam
 
R

Ron Rosenfeld

Following on from that last post I have updated my spreadsheet to try
and explain better what I am trying to do.

Ron I tried your formula but could not get it to work and that is
probably largely because I did not explain myself properly - apologies
for that..

https://skydrive.live.com/view.aspx?cid=CB2CB4829572A60A&resid=CB2CB4829572A60A!292
Click to expand...

Your explanation was OK, but your examples were unrepresentative of your actual environment that the solution becomes useless.

Also, when you write "could not get it to work", what do you mean?

It clearly will not deal with your conditional formatting as your "real" data is drastically different from the examples you provided. But "could not get it to work" is not useful in helping devise something that might work.
 
R

Ron Rosenfeld

Following on from that last post I have updated my spreadsheet to try
and explain better what I am trying to do.

Ron I tried your formula but could not get it to work and that is
probably largely because I did not explain myself properly - apologies
for that..

https://skydrive.live.com/view.aspx?cid=CB2CB4829572A60A&resid=CB2CB4829572A60A!292
Click to expand...

If, indeed, your conditional formatting is limited to:

Either an expression, as in your cell A1, or various cell values, as in some of the other cells
AND IF
where there are several possible CF conditions, only ONE might be applicable (i.e. the conditions do not overlap),
then the following UDF should work:

==============================
Option Explicit
Function CountFmt(rg As Range) As Long
Dim c As Range
Dim t As Long
Dim fc As FormatCondition
Dim c1 As Double, c2 As Double
For Each c In rg
If c.Interior.ColorIndex <> xlColorIndexNone Then
t = t + 1
ElseIf c.FormatConditions.Count > 0 Then
For Each fc In c.FormatConditions
Select Case fc.Type
Case Is = xlCellValue
If fc.Operator <> xlBetween Then
MsgBox ("Conditional Format cannot be processed")
Exit Function
End If
c1 = Evaluate(fc.Formula1)
c2 = Evaluate(fc.Formula2)
If c.Value >= c1 And c.Value <= c2 Then
t = t + 1
End If
Case Is = xlExpression
If Evaluate(fc.Formula1) = True Then t = t + 1
Case Else
MsgBox ("Conditional Format cannot be processed")
Exit Function
End Select
Next fc
End If
Next c
CountFmt = t
End Function
=======================================

So far as counting only cells which have a yellow fill, you've got most of the pieces to have been able to do this yourself. Try:

====================
Function CountYellow(rg As Range) As Long
Dim c As Range
Dim t As Long
For Each c In rg
If c.Interior.Color = vbYellow Then t = t + 1
Next c
CountYellow = t
End Function
=====================
 
S

Sam Harman

Hi Ron, I am really sorry if I have not explained myself properly.

You have no idea how much you have helped me since I started
developing my spreadsheet and how much time your modules have saved
me.

I think you know how grateful I am and I am amazed at your knowledge,
patience and willingness to help when I manage to frustrate you with
poor examples or lack of clarity in what I am trying to achieve...

I will try this module and let you know how I get on...

Thank you once again for all your help

Kind regards

Sam
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Attn Ron Rosenfeld 1
Attn Ron Rosenfeld 10
VBA Coding Help for Beginner 0
Copy unique values problem 5
VBA - (re-) Set a Table Style 2
Closing PDF file from Excel VBA (Adobe Reader, Adobe Acrobat, Browser) 0
Drop down list control value in vba 2
VBA Export to PDF 0

Top