Count precentage of cells filled with a specific color

[southcity]

Hi, I would like to get a percentage for every row which is filled with green color. White cells are total number of cells and as time goes by I will be filling these white cells with green color. Gray cells should not be counted at all. Look at my sketch. Thanks for the help.
Note about the total: 11 (green cells) / 80 (total cells: white+green)

Edit: Sorry, the first row should be: 2/2=1=100%, because the gray cells should not be counted.

 

[ranman256]

paste the code into a module,
change the number for YOUR color of green. (mine was: Const kGRN = 13561798. )
put cursor on cell then run MsgMyGreen to get yours

then run: GetColorPct

 

[ranman256]

Sub GetColorPct()
Dim rng As Range
Dim iRows As Integer, iCols As Integer
Dim r As Integer, c As Integer
Dim iGrnCt As Integer, iWhtCt As Integer, iGrnTot As Integer, iWhtTot As Integer

Const kGRN = 13561798

Set rng = Range("H4:R18")
iRows = rng.Rows.Count
iCols = rng.Columns.Count

Range("H4").Select
For r = 0 To iRows - 1
   iGrnCt = 0
   iWhtCt = 0
   
   For c = 0 To iCols - 1
      
      If ActiveCell.Row = 8 Then
      Beep
      End If
      
      Select Case ActiveCell.Interior.Color
         Case kGRN
           iGrnCt = iGrnCt + 1
         Case vbWhite
           iWhtCt = iWhtCt + 1
      End Select
      
      ActiveCell.Offset(0, 1).Select
   Next
   
   iGrnTot = iGrnTot + iGrnCt
   iWhtTot = iWhtTot + iWhtCt
   
   Select Case True
        Case iWhtCt = 0 And iGrnCt = 0
          ActiveCell.FormulaR1C1 = "=0"
        Case iWhtCt = 0 And iGrnCt > 0
          ActiveCell.FormulaR1C1 = "=1"
        Case Else
          ActiveCell.FormulaR1C1 = "=" & iGrnCt & "/" & iWhtCt
   End Select
   
   ActiveCell.Style = "Percent"
   ActiveCell.Offset(1, -iCols).Select
      
Next

ActiveCell.Offset(0, iCols).Select 'next row
ActiveCell.Offset(0, -1).Value = "Total:"

ActiveCell.FormulaR1C1 = "=" & iGrnTot & "/" & iWhtTot
ActiveCell.Style = "Percent"

MsgBox "done"
End Sub


Public Sub MsgMyGreen()
MsgBox ActiveCell.Interior.Color
End Sub