Color coded schedule

[Remburg]

Hello,

I am working on a schedule for work at this moment. I am using a range of colors, however, I wish that when I put green color on a person I wish it to count as a 1 FTE resource, and if I put orange I wish the function to count it as ½ FTE resource. I have been googling but cannot get my VBA to work.

I have found a pre built function that goes like following:

'Code created by Sumit Bansal from *CENSORED*
Function GetColorCount(CountRange As Range, CountColor As Range)
Dim CountColorValue As Integer
Dim TotalCount As Integer
CountColorValue = CountColor.Interior.ColorIndex
Set rCell = CountRange
For Each rCell In CountRange
If rCell.Interior.ColorIndex = CountColorValue Then
TotalCount = TotalCount + 1
End If
Next rCell
GetColorCount = TotalCount
End Function

So I tried to rewrite the function to support two different colors as following:


Function GetColorCount(CountRange As Range, CountColor As Range, CountColor2 As Range)
Dim CountColorValue As Integer
Dim CountColor2Value As Integer
Dim TotalCount As Integer
CountColorValue = CountColor.Interior.ColorIndex
CountColor2Value = CountColor2.Interior.ColorIndex
Set rCell = CountRange
For Each rCell In CountRange
If rCell.Interior.ColorIndex = CountColorValue Then
TotalCount = TotalCount + 1
ElseIf rCell.Interior.ColorIndex = CountColorValue2 Then
TotalCount = TotalCount + 0.5
End If
Next rCell
GetColorCount = TotalCount
End Function



But my edition of Sumit Bansal's function won't calculate the orange ones cells. Would anyone please be kind and help me out in finding what unforgivable mistake I am doing?

Regards, Remburg

 

[Remburg]

Update:

I realized I made some true rookie mistakes which I blame my tiredness.

Following code worked:

Function GetColorCount(CountRange As Range, CountColor As Range, CountColor2 As Range)
Dim CountColorValue As Integer
Dim CountColor2Value As Double
Dim TotalCount As Double
CountColorValue = CountColor.Interior.ColorIndex
CountColor2Value = CountColor2.Interior.ColorIndex
Set rCell = CountRange
For Each rCell In CountRange
If rCell.Interior.ColorIndex = CountColorValue Then
TotalCount = TotalCount + 1
ElseIf rCell.Interior.ColorIndex = CountColor2Value Then
TotalCount = TotalCount + 0.5
End If
Next rCell
GetColorCount = TotalCount
End Function

However, I have a last question. The calculation won't automatically calculate any changes in the cells in the range. I have tried several different subs on getting the function to reevaluate but I cannot make it work. I have tried automatic calculation and also to employ SelectionChange but without any success. Does anyone know a good way to get the function to recalculate when changing selection?

 

[Fluff]

How about

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Me.Calculate
End Sub

but this will recalculate the sheet whenever you select a new cell