any vba/excel experts around

WaywardDriver

dipsomaniac wrote: »

thank you. i have pm'ed you a dropbox link to the spreadsheet without any vba script

Thanks - just realised what problem is. My test data didn't have any non-colour-filled cells while your real data has. Will get back to you with revised code.

Heedtheadvice

...and in version of Excel 2007 it appears under the Developer Menu too.
Select a cell of interest on a sheet
Under View or Developer menu select and Macro items.
select record Macro
Give it a unique name (that might be the default one but not then very explicit) and then 'OK'
Change the cell to the conditions you wish to know about such as solid colour fill or pattens woth gradient and two colours - as per what you would select manually:
when done select stop macro.
You can then find that macro's vba code under the Macros icon next ti the VBA Icon on the menu bar or hit ALT+f8. Select the macro just recorded and there you have the code
(Steps taken for Excel version 2007 most others will be similar)

WaywardDriver

WaywardDriver wrote: »

Thanks - just realised what problem is. My test data didn't have any non-colour-filled cells while your real data has. Will get back to you with revised code.

Try

Function CountCcolor(range_data As Range, criteria As Range)
Dim datax As Range
If criteria.Interior.Pattern = xlSolid Then
Dim xcolor As Long
xcolor = criteria.Interior.ColorIndex
For Each datax In range_data
If datax.Interior.ColorIndex = xcolor Then CountCcolor = CountCcolor + 1
Next
Else
Dim xcol(2), ycol(2) As Long
Dim n As Integer
n = 0
For Each cs In criteria.Interior.Gradient.ColorStops
n = n + 1
xcol(n) = cs.Color
Next
For Each datax In range_data
If datax.Interior.Pattern = 4000 Then
n = 0
For Each cs In datax.Interior.Gradient.ColorStops
n = n + 1
ycol(n) = cs.Color
Next
If ycol(1) = xcol(1) And ycol(2) = xcol(2) Then CountCcolor = CountCcolor + 1
End If
Next
End If
End Function

with the line in bold replacing the line in 1st version. On my version of Excel and testing various multi-colour cell fill backgrounds the value of Interior.Pattern was always 4000 so this will exclude any non-coloured cells.

dipsomaniac

thanks waywarddriver. not sure what i am doing wrong but i am getting '0' for each of the multicolour cells. i replaced the original vba script with the new script above.

WaywardDriver

dipsomaniac wrote: »

thanks waywarddriver. not sure what i am doing wrong but i am getting '0' for each of the multicolour cells. i replaced the original vba script with the new script above.

I could only download the Excel file you sent as text so couldn't test. Only thing I can think of is the criteria and data gradient colours might have been added in different order. So try below with change in bold:

Function CountCcolor(range_data As Range, criteria As Range)
Dim datax As Range
If criteria.Interior.Pattern = xlSolid Then
Dim xcolor As Long
xcolor = criteria.Interior.ColorIndex
For Each datax In range_data
If datax.Interior.ColorIndex = xcolor Then CountCcolor = CountCcolor + 1
Next
Else
Dim xcol(2), ycol(2) As Long
Dim n As Integer
n = 0
For Each cs In criteria.Interior.Gradient.ColorStops
n = n + 1
xcol(n) = cs.Color
Next
For Each datax In range_data
If datax.Interior.Pattern = 4000 Then
n = 0
For Each cs In datax.Interior.Gradient.ColorStops
n = n + 1
ycol(n) = cs.Color
Next
If (ycol(1) = xcol(1) and ycol(2) = xcol(2)) or (ycol(1) = xcol(2) and ycol(2) = xcol(1)) Then CountCcolor = CountCcolor + 1
End If
Next
End If
End Function

Heedtheadvice

Have done a bit of debugging for you.


Although the code might be better written more explicitly commented, without any errors caused by calling (there really is no error handling in the code) then there was only one change for it to work for me so well done Wayward


see rem comment at changed line as follows:


Function CountCcolor(range_data As Range, criteria As Range)
Dim datax As Range

If criteria.Interior.Pattern = xlSolid Then
Dim xcolor As Long
xcolor = criteria.Interior.ColorIndex

For Each datax In range_data
If datax.Interior.ColorIndex = xcolor Then CountCcolor = CountCcolor + 1
Next


Else
Dim xcol(2), ycol(2) As Long
Dim n As Integer
n = 0
For Each cs In criteria.Interior.Gradient.ColorStops
n = n + 1
xcol(n) = cs.Color
Next

For Each datax In range_data
If datax.Interior.Pattern = 4001 Then Rem test value changed to 4001 from 4000
n = 0

For Each cs In datax.Interior.Gradient.ColorStops
n = n + 1
ycol(n) = cs.Color
Next

If (ycol(1) = xcol(1) And ycol(2) = xcol(2)) Or (ycol(1) = xcol(2) And ycol(2) = xcol(1)) Then CountCcolor = CountCcolor + 1
End If
Next


End If

End Function


That works for me now (XL 2007)

Trust that will now work for you Dipso

WaywardDriver

Heedtheadvice wrote: »

Have done a bit of debugging for you.

Although the code might be better written more explicitly commented, without any errors caused by calling (there really is no error handling in the code) then there was only one change for it to work for me so well done Wayward

see rem comment at changed line as follows:

If datax.Interior.Pattern = 4001 Then Rem test value changed to 4001 from 4000

That works for me now (XL 2007)

Afraid commenting never one of my strengths - not a professional programmer.
But your change doesn't work for me (Excel 2016) which is why I tended not to use Excel when developing applications - what works in one version doesn't in another. Used VB.net and SQLserver instead.

WaywardDriver

Think have got to bottom of this:

If datax.Interior.Pattern = 4001 is correct for the OP's data where the colour gradient had Fill Effect - Shading Style - From Centre whereas my test data had the default option of Horizontal which gave .Interior.Pattern = 4000.
So nothing to do with Excel version. Moral is to test using actual data if possible. Thank you HeedTheAdvice.

Heedtheadvice

"Commenting" was just a passing comment! It just helps the reader to understand the code. No problem.


I do find it a bit surprising that what works in 2007 does not work in 2016. Not impossible by any means but most changes I have come across are for new object model elements with legacy ones still supported.


I located the change I made by putting in a breakpoint at the first if statement; adding the function call to the cell that tests for the two colour to be tested;

and then stepping through called function code,
until at the " If datax.Interior.Pattern = 4000 Then " line
watching the value of the ' .pattern' property (hove over or add a watch) and that value in my workbook turned out to be 4001 rather than 4000.


Could it be we have selected slightly different patterns for the colour combination to test? Edit: As per your post Wayward!


If Dipso did the same break/step and watch then that would sort out which was correct on that posters sheet. Can you post the version being used, Dipso.


Further thought.....
Back a stage or two recording the macro for setting the colours I had the following result for that pattern
"Interior.Pattern = xlPatternRectangularGradient" and that built in constant value was 4001.



Perhaps it would be better to change the function code I have been referring to to be



" If datax.Interior.Pattern = xlPatternRectangularGradient Then "


(or whatever built in constant is returned during the recorded macro for the particular pattern that has been manually selected!)

Heedtheadvice

Ah! we just posted at the same time!

Great, now if Dipso is awake progress might be made!!