VBA code to count certain criteria (1 Viewer)

[Lensmeister]

Hi all,

Hope someone can help me.

I am in need of assistance with the creation of VBA code thaat counts cells that have certain criteria.

The background (interior colour) is = 35 and the cell contents need to equal a named cell called filename.

In laymans terms if it were a formula would be roughly:

In the range of cells called "AllGoals" count the cells that have a background colour of 35 and if the cell has the same contents as cell "filename" then display it in the sheet called profile in cell "G10".

I have attached a copy of the xls to hopefully clarify things.

Thanks in advance.

 

[scott-atkinson]

Why would you NOT want to count the penalties scored by a person if they are not of the background color, surely a penalty scored is a penalty scored...

 

[Brianwarnock]

I also defined Profiles!G10 as Penalties named range

Brian

Sub mysub()
Dim rng As Range
Dim pentot As Long
pentot = 0
For Each rng In Range("ALLGoals")
    If rng.Value = Range("filename").Value And rng.Interior.ColorIndex = 35 Then
      pentot = pentot + 1
    End If
Next rng
Range("Penalties") = pentot

End Sub

 

[Lensmeister]

Why would you NOT want to count the penalties scored by a person if they are not of the background color, surely a penalty scored is a penalty scored...

Indeed a penalty scored is a penalty scored BUT when they are mixed in with open play goals (in the array ALLgoals) then it is useful to differentiate.

Brian I am going to give this a test.

Just as an aside I have another function that does not calculate when other cells are coloured. The only way to get it to run is to go into the cell and press Enter ... .Why is this ? And is there a way to "force" the function to work ?

 

[Rx_]

If you are up for a small challange.... here is the result formula that I program into Excel reports.
The Buddy control to the left contains the unique text found in the data area below. For example: Prog Sent to field can be changed to Staking and the number on the next right cell (with formula below) will update.

This report has 9,674 (minus 6) records because the data starts on row 6.
The number 9674 is programmed from a variable for the record count plus 6. (thus AG6).

A different function runs against the Primary Key and turns the Many rows to a light-gray. By using the Subtotal (option3) with the offset, only the unique values are counted. This way, end users can filter columns, and the unique values count is displayed. my variable intRecordCount comes from an Access recordset.

=SUMPRODUCT(SUBTOTAL(3, OFFSET(AG6:AG9674, ROW(AG6:AG9674)-ROW(AG6),0,1)),--(AG6:AG9674=C2))

The code to create the formula above would look like this:

ObjXL.Range("B2").Select
    With ObjXL.Selection.Font
          .Size = 10
    End With
    ObjXL.Selection.Font.Bold = False
              ObjXL.Range("B2").Select   ' offset 4
          ObjXL.ActiveCell.FormulaR1C1 = _
              "=SUMPRODUCT(SUBTOTAL(3, OFFSET(R[4]C[31]:R[" & intMaxRecordCount & "]C[31], ROW(R[4]C[31]:R[" & intMaxRecordCount & "]C[31])-ROW(R[4]C[31]),0,1)),--(R[4]C[31]:R[" & intMaxRecordCount & "]C[31]=RC[-1]))"
 
   ObjXL.Range("B3").Select
    With ObjXL.Selection.Font
          .Size = 10
    End With
    ObjXL.Selection.Font.Bold = False
              ObjXL.Range("B3").Select   ' offset 3
          ObjXL.ActiveCell.FormulaR1C1 = _
              "=SUMPRODUCT(SUBTOTAL(3, OFFSET(R[3]C[31]:R[" & intMaxRecordCount & "]C[31], ROW(R[3]C[31]:R[" & intMaxRecordCount & "]C[31])-ROW(R[3]C[31]),0,1)),--(R[3]C[31]:R[" & intMaxRecordCount & "]C[31]=RC[-1]))"
 
    ObjXL.Range("B4").Select
    With ObjXL.Selection.Font
          .Size = 10
    End With
    ObjXL.Selection.Font.Bold = False
              ObjXL.Range("B4").Select   ' offset 2
          ObjXL.ActiveCell.FormulaR1C1 = _
              "=SUMPRODUCT(SUBTOTAL(3, OFFSET(R[2]C[31]:R[" & intMaxRecordCount & "]C[31], ROW(R[2]C[31]:R[" & intMaxRecordCount & "]C[31])-ROW(R[2]C[31]),0,1)),--(R[2]C[31]:R[" & intMaxRecordCount & "]C[31]=RC[-1]))"

It is probably more than you need, the method above looks like your solution. This works well with Filtered Columns and 1 to many listings.
I had a couple of minutes before lunch and thought it might be another consideration for someone out there.

 

[Lensmeister]

I also defined Profiles!G10 as Penalties named range

Brian

Sub mysub()
Dim rng As Range
Dim pentot As Long
pentot = 0
For Each rng In Range("ALLGoals")
    If rng.Value = Range("filename").Value And rng.Interior.ColorIndex = 35 Then
      pentot = pentot + 1
    End If
Next rng
Range("Penalties") = pentot

End Sub

I tried this but it doesn't give me an answer in the cell called Penalties .

 

[Lensmeister]

Wow RX_ that is a serious bit of code.

I think it's a bit advanced for my workbook .Thank you

 

[Brianwarnock]

What actually happens? Have you hard coded the cell rather than created a named range Penalties to see if that gives you the result.

Brian

 

[Lensmeister]

I placed the function in a Module

Named the cell "G5" as 'Penalties' no result shows in the cell

I have put it in my overall workbook (not the sample I placed here)

It is in a xls (created originally on Windows 2003)

And macros enabled

Edit:

There maybe a conflict in the code as i have a lot of macros and code and I suspect that rng may be used elsewhere.

I can change all rng to rngP to test I guess

 

[Brianwarnock]

just realised that you called it a function, it is a Sub, you could make it a function but would need to change

Range("Penalties") = pentot

to

functionname = pentot

brian

 

[Brianwarnock]

For a function to recalculate automatically it needs to know that data affecting it has changed, so if you opt for a function say myf, code
Function myf(a as range) as long
and in the worksheet
=myf(ALLGoals)

this is not used but allows Excel to know that a recalculation is needed, I suppose you need to add filename in there too.

Brian

 

[Lensmeister]

Morning Brian,

I have changed the code from a sub to a function thus:

'Function mysub()
'Dim rng As Range
'Dim pentot As Long
'pentot = 0
'For Each rng In Range("ALLGoals")
'    If rng.Value = Range("filename").Value And rng.Interior.ColorIndex = 35 Then
'      pentot = pentot + 1
'    End If
'Next rng
'functionname = pentot
'
'End Function

I have a combo box on the Profile page that changes cell "I1". This control changes all the other vlookups and sumproducts on the page.

I guess I could put something in to the code below to force the calc of the above function ???

Sub DropDown1_Change()
???? 
End Sub

I hope this is making sense.

I cannot upload the full spreadsheet because even zipped it is huge (25MB) in size also the combo and vlookups, sumproducts all feed from different sheets.

 

[Brianwarnock]

When I said functionname = Pentot I meant the name of the function , in your example mysub, however you appear to have ignored the next post detailing how to ensure recalculation.
If you are going to place something on the worksheet to do this then I would keep the Sub and put a command button to run it on the worksheet, that is a simple and effective approach.

Brian

 

[Lensmeister]

Hi Brian,

Been a bad day :banghead: so I hope what I am about to post makes sense and is right.

I have used this code in a module making it a function. (I have had to change rng to rngP due to the fact I have rng in another bit of code).

Function myPen(a As Range)
Dim rngP As Range
Dim pentot As Long
pentot = 0
For Each rngP In Range("ALLGoals")
    If rngP.Value = Range("filename").Value And rngP.Interior.ColorIndex = 35 Then
      pentot = pentot + 1
    End If
Next rngP
Range("Penalties") = pentot
End Function

In the cell named "Penalties" I have place the formula

=mypen(AllGoals)

Now initially this showed the number of penalties as 0 but this is incorrect for the player I chose (should be about 30).

Then the macros ran again after I pressed save and it came up with a warning about circular Reference.

I cannot see where I am going wrong.

 

[Brianwarnock]

It should end mypen = pentot

A function returns a result in the cell in which it is placed.

Brian

 

[Lensmeister]

Thanks for you paitence.

Function myPen(a As Range)
Dim rngP As Range
Dim pentot As Long
pentot = 0
For Each rngP In Range("ALLGoals")
    If rngP.Value = Range("filename").Value And rngP.Interior.ColorIndex = 35 Then
      pentot = pentot + 1
    End If
Next rngP
myPen = pentot
End Function

And it works

Brian I cannot thank you enough.

The only thing I noticed is that when I select a player then has never scored a penalty (i.e. a goalkeeper) it remail on the total for the last player.

 

[Brianwarnock]

Glad we eventually got there.
Please don't take offence but I think that maybe you should read through the thread to see the difference between a Sub and a Function, but then maybe you were just having a bad day.

Brian

 

[Lensmeister]

Glad we eventually got there.
Please don't take offence but I think that maybe you should read through the thread to see the difference between a Sub and a Function, but then maybe you were just having a bad day.

Brian

Bad day and a half :banghead:

Sorry for being dense. Usually I get things like this easily once explained.

No offence taken.

Is there a way to "reset" the pentot to zero before calcs are made to stop the glitch I posted?

The only thing I noticed is that when I select a player then has never scored a penalty (i.e. a goalkeeper) it remail on the total for the last player.

 

[Lensmeister]

Sorted the reset problem.

In the cell named "Penalties" I have place the formula

=myPen(filename)

Now when the name changes ... BINGO the penalty count changes

Also just as aside ....

I can modify the code changing the names of varibles and rng etc. to use it to completely do away with an entire seet that lists players sent off. This code can be recycled

 

[Brianwarnock]

Ah! I did say in post 11 that you might need both ALLGoals and filename to be passed in the function even tho you are not using them, I'd forgotten that since then, so

= myPen(ALLGoals,filename)
On the worksheet
And
Function myPen(a as range, f as range) as Long

For the function.

This will ensure that any changes to either or both data areas cause a recalculation. Normally with a function the passed info is used in the function but with named ranges you can address them as in this function, but if you don't include them in the worksheet function Excel will not know to recalculate on changes.

Brian