Count and display in cell
Ok I have an Excel workbook that contains a schedule (51 worksheets total). Each cell has intials in it and if that person has taken a day off the cell is highlighted a certain color (yellow, rose, or red). What I need to do is have something that goes through and counts what intials have what color and then display in a cell the number. So:
If cell contains "initials" and cell color is "color"
Then count and display in "cell"
Example:
If cell contains "JJ" and cell color is "Yellow"
Then count and display in "A2"
I know it is possible to do this but I'm not sure how.
Tiger
I found this code but it doesn't seem to work right and is driving me nuts (this is just for highlighted cells)
Function CountColor(rColor As Range, rSumRange As Range)
Dim rCell As Range
Dim iCol As Integer
Dim vResult
iCol = rColor.Interior.ColorIndex
For Each rCell In rSumRange
If rCell.Interior.ColorIndex = iCol Then
vResult = vResult + 1
End If
Next rCell
End Function
Here is the basic principle of doing what you would like.
Sub countColour()
For Each cell In Range("A1:A25")
col = cell.Interior.ColorIndex
If col = 6 Then
yellowcount = yellowcount + 1
End If
Next
MsgBox ("There were " & Str(yellowcount) & " yellow cells")
End Sub
You could add a select case statement and increment each colour count
ChasAA
The count on the colored cells is great! That solves one part of my problem. No I just need to get it to count cells that contain certian initials and cell color, then puts the answer into a cell that I assign.
Thanks for your help.
How many different colours will you have and how many different initials? and do you want all the result in one cell ie CC yellow=2 red=4 rose=1 TP yellow=5 red=1 rose=6
ChasAA
There three diffrent colors (red, rose, and yellow) and 10 diffrent initials (DA, TM, BG, GS, Gary S, JJ, CT, DF, PM, and CE).
The way I would like it displayed is in three sepreate cells for each person. Like this:
DF |
Sick | 3 |
Vacation | 5 |
Unexcused | 0 |
Thanks again for the help!
Hello,
Try the following code:
You could use the ReDim statement to allow for extra employee names if you like.
I used range A1to A100 to be filled with names and colours.
Any probs, just ask.
ChasAA
[Code start]
Sub process()
Dim staffMember() As Variant
Dim lastAddPos As Integer
Dim staffMemberFound As Boolean
Dim colourOffset As Integer
Dim staffName As String
Dim staffCount As Integer
Dim counter As Integer
Dim staffIndex As Integer
Dim rowOffset As Integer
staffCount = 10
lastAddPos = 0
ReDim staffMember(staffCount, 4)
For Each cell In Range("A1:A100")
staffMemberFound = False
colour = cell.Interior.ColorIndex
staffName = cell.Value
Select Case colour
Case 3 ' red
colourOffset = 2
Case 6 ' yellow
colourOffset = 3
Case 7
colourOffset = 4
End Select
For counter = 1 To staffCount
If staffName = staffMember(counter, 1) Then
staffMemberFound = True ' if employee already in array then
staffIndex = counter ' note that place
Exit For
End If
Next
If Not staffMemberFound Then ' if emp not in array then need to add
lastAddPos = lastAddPos + 1 ' after the last added positon
staffMember(lastAddPos, 1) = staffName
staffIndex = lastAddPos
End If
staffMember(staffIndex, colourOffset) = staffMember(staffIndex, colourOffset) + 1
' increment the appropriate array elements
Next
counter = 1
rowOffset = 0
Cells(2, 3).Select
Do While staffMember(counter, 1) <> ""
Selection.Offset(rowOffset, 0) = staffMember(counter, 1)
Selection.Offset(rowOffset + 1, 0) = "Sick"
Selection.Offset(rowOffset + 1, 0).Interior.ColorIndex = 6
Selection.Offset(rowOffset + 1, 1) = staffMember(counter, 3)
Selection.Offset(rowOffset + 2, 0) = "Vacation"
Selection.Offset(rowOffset + 2, 0).Interior.ColorIndex = 7
Selection.Offset(rowOffset + 2, 1) = staffMember(counter, 4)
Selection.Offset(rowOffset + 3, 0) = "Unexcused"
Selection.Offset(rowOffset + 3, 0).Interior.ColorIndex = 3
Selection.Offset(rowOffset + 3, 1) = staffMember(counter, 2)
counter = counter + 1
rowOffset = rowOffset + 5
Loop
End Sub
[Code End]
Hello,
Try the following code:
You could use the ReDim statement to allow for extra employee names if you like.
I used range A1to A100 to be filled with names and colours.
Any probs, just ask.
ChasAA
[Code start]
Sub process()
Dim staffMember() As Variant
Dim lastAddPos As Integer
Dim staffMemberFound As Boolean
Dim colourOffset As Integer
Dim staffName As String
Dim staffCount As Integer
Dim counter As Integer
Dim staffIndex As Integer
Dim rowOffset As Integer
staffCount = 10
lastAddPos = 0
ReDim staffMember(staffCount, 4)
For Each cell In Range("A1:A100")
staffMemberFound = False
colour = cell.Interior.ColorIndex
staffName = cell.Value
Select Case colour
Case 3 ' red
colourOffset = 2
Case 6 ' yellow
colourOffset = 3
Case 7
colourOffset = 4
End Select
For counter = 1 To staffCount
If staffName = staffMember(counter, 1) Then
staffMemberFound = True ' if employee already in array then
staffIndex = counter ' note that place
Exit For
End If
Next
If Not staffMemberFound Then ' if emp not in array then need to add
lastAddPos = lastAddPos + 1 ' after the last added positon
staffMember(lastAddPos, 1) = staffName
staffIndex = lastAddPos
End If
staffMember(staffIndex, colourOffset) = staffMember(staffIndex, colourOffset) + 1
' increment the appropriate array elements
Next
counter = 1
rowOffset = 0
Cells(2, 3).Select
Do While staffMember(counter, 1) <> ""
Selection.Offset(rowOffset, 0) = staffMember(counter, 1)
Selection.Offset(rowOffset + 1, 0) = "Sick"
Selection.Offset(rowOffset + 1, 0).Interior.ColorIndex = 6
Selection.Offset(rowOffset + 1, 1) = staffMember(counter, 3)
Selection.Offset(rowOffset + 2, 0) = "Vacation"
Selection.Offset(rowOffset + 2, 0).Interior.ColorIndex = 7
Selection.Offset(rowOffset + 2, 1) = staffMember(counter, 4)
Selection.Offset(rowOffset + 3, 0) = "Unexcused"
Selection.Offset(rowOffset + 3, 0).Interior.ColorIndex = 3
Selection.Offset(rowOffset + 3, 1) = staffMember(counter, 2)
counter = counter + 1
rowOffset = rowOffset + 5
Loop
End Sub
[Code End]
Hello,
Try the following code:
You could use the ReDim statement to allow for extra employee names if you like.
I used range A1to A100 to be filled with names and colours.
Any probs, just ask.
ChasAA
[Code start]
Sub process()
Dim staffMember() As Variant
Dim lastAddPos As Integer
Dim staffMemberFound As Boolean
Dim colourOffset As Integer
Dim staffName As String
Dim staffCount As Integer
Dim counter As Integer
Dim staffIndex As Integer
Dim rowOffset As Integer
staffCount = 10
lastAddPos = 0
ReDim staffMember(staffCount, 4)
For Each cell In Range("A1:A100")
staffMemberFound = False
colour = cell.Interior.ColorIndex
staffName = cell.Value
Select Case colour
Case 3 ' red
colourOffset = 2
Case 6 ' yellow
colourOffset = 3
Case 7
colourOffset = 4
End Select
For counter = 1 To staffCount
If staffName = staffMember(counter, 1) Then
staffMemberFound = True ' if employee already in array then
staffIndex = counter ' note that place
Exit For
End If
Next
If Not staffMemberFound Then ' if emp not in array then need to add
lastAddPos = lastAddPos + 1 ' after the last added positon
staffMember(lastAddPos, 1) = staffName
staffIndex = lastAddPos
End If
staffMember(staffIndex, colourOffset) = staffMember(staffIndex, colourOffset) + 1
' increment the appropriate array elements
Next
counter = 1
rowOffset = 0
Cells(2, 3).Select
Do While staffMember(counter, 1) <> ""
Selection.Offset(rowOffset, 0) = staffMember(counter, 1)
Selection.Offset(rowOffset + 1, 0) = "Sick"
Selection.Offset(rowOffset + 1, 0).Interior.ColorIndex = 6
Selection.Offset(rowOffset + 1, 1) = staffMember(counter, 3)
Selection.Offset(rowOffset + 2, 0) = "Vacation"
Selection.Offset(rowOffset + 2, 0).Interior.ColorIndex = 7
Selection.Offset(rowOffset + 2, 1) = staffMember(counter, 4)
Selection.Offset(rowOffset + 3, 0) = "Unexcused"
Selection.Offset(rowOffset + 3, 0).Interior.ColorIndex = 3
Selection.Offset(rowOffset + 3, 1) = staffMember(counter, 2)
counter = counter + 1
rowOffset = rowOffset + 5
Loop
End Sub
[Code End]
I did not mean to post the same three times. Its just that when I was hiiting Post an error came up each time !!
Sorry
ChasAA
Ok this doesn't do what I need it to. Let me rephrase my problem (btw I do appreciate all of you work and effort. I am fairly new to vb and I could use all the help I can get lol)
I have a workbook with several worksheets in it. Each worksheet looks like this (sorry about it being so big):
| Date | 06' | 12-Aug | 13-Aug | 14-Aug | 15-Aug | 16-Aug | 17-Aug | 18-Aug | 19-Aug | 20-Aug | 21-Aug | 22-Aug | 23-Aug | 24-Aug | 25-Aug | 26-Aug | 27-Aug | 28-Aug | 29-Aug | 30-Aug | 31-Aug | 1-Sep |
| 12am | A | OFF | OFF | DA | DA | DA | DA | DA | OFF | OFF | GS & PM | GS & PM | GS & PM | GS & PM | GS & PM | OFF | OFF | DF | DF | DF | DF | DF |
| to | B | TM | TM | OFF | OFF | TM | TM | TM | DA | DA | OFF | OFF | DA | DA | DA | GS & PM | GS & PM | OFF | OFF | GS & PM | GS & PM | GS & PM |
| 8am | C | BG | BG | BG | BG | BG | OFF | OFF | TM | TM | TM | TM | TM | OFF | OFF | DA | DA | DA | DA | DA | OFF | OFF |
| 8am | A | OFF | OFF | CE | CE | CE | CE | CE | OFF | OFF | BG | BG | BG | BG | BG | OFF | OFF | TM | TM | TM | TM | TM |
| to | B | GARY S | GARY S | OFF | OFF | GARY S | GARY S | GARY S | CE | CE | OFF | OFF | CE | CE | CE | BG | BG | OFF | OFF | BG | BG | BG |
| 4pm | C | JJ | JJ | JJ | JJ | JJ | OFF | OFF | GARY S | GARY S | GARY S | GARY S | GARY S | OFF | OFF | CE | CE | CE | CE | CE | OFF | OFF |
| 4pm | A | OFF | OFF | CT | CT | CT | CT | CT | OFF | OFF | JJ | JJ | JJ | JJ | JJ | OFF | OFF | GARY S | GARY S | GARY S | GARY S | GARY S |
| to | B | DF | DF | OFF | OFF | DF | DF | DF | CT | CT | OFF | OFF | CT | CT | CT | JJ | JJ | OFF | OFF | JJ | JJ | JJ |
| 12am | C | GS & PM | GS & PM | GS & PM | GS & PM | GS & PM | OFF | OFF | DF | DF | DF | DF | DF | OFF | OFF | CT | CT | CT | CT | CT | OFF | OFF |
This is our operator's schedual. If one of them takes a day off for being sick, vacation, or unexcused absence we highlight that day for the employee with the corrisponding color (so if JJ takes a sick day on Aug 15th the cell is highlighted yellow). What I need is to be able to have a seperate worksheet in the workbook that all it does is count the number of highlighted cells with each set of initials from all the other worksheets and displays those numbers in a format similar to the one I posted earlier.
I tried your code but it only works on one sheet and overwrites my cells. Maybe I put it in wrong? I put it under a module and had to hit the play button to get it to do anything.
Like I said I'm fairly new to VB and can use all the help I can get lol.
Thanks again
Hello,
With a few changes it will work for multiple sheets. The end results will be added to a sheet at the end of your current sheets.
BUT. All your sheets must have the same range where the data is ie B4:Z26 (or whatever the area is)
Change the Line in the code to reflect this.
"OFF" will be treated as an employee but since this type of cell will never be coloured by you, it does not matter. You will just get a statistics for "OFF"
It will treat GS & PM as one employee.
If you had posted the above in the first place !!!!. only joking !!
Here is the amended code.
[Code]
Option Base 1
Sub process()
Dim staffMember(15, 4) As Variant
Dim lastAddPos As Integer
Dim staffMemberFound As Boolean
Dim colourOffset As Integer
Dim staffName As String
Dim staffCount As Integer
Dim counter As Integer
Dim staffIndex As Integer
Dim rowOffset As Integer
Dim ws As Integer ' ADDED
staffCount = 10
lastAddPos = 0
For ws = 1 To Worksheets.Count ' ADDED -
Worksheets(ws).Select ' ADDED -
'ReDim staffMember(staffCount, 4) ' REMOVED
For Each cell In Range("A1:A100") ' CHANGE THIS RANGE TO WHATEVER SUITS YOU
staffMemberFound = False
colour = cell.Interior.ColorIndex
staffName = cell.Value
Select Case colour
Case 3 ' red
colourOffset = 2
Case 6 ' yellow
colourOffset = 3
Case 7
colourOffset = 4
End Select
For counter = 1 To staffCount
If staffName = staffMember(counter, 1) Then
staffMemberFound = True ' if employee already in array then
staffIndex = counter ' note that place
Exit For
End If
Next
If Not staffMemberFound Then ' if emp not in array then need to add
lastAddPos = lastAddPos + 1 ' after the last added positon
staffMember(lastAddPos, 1) = staffName
staffIndex = lastAddPos
End If
staffMember(staffIndex, colourOffset) = staffMember(staffIndex, colourOffset) + 1
' increment the appropriate array elements
Next
Next ws ' ADDED --
Worksheets.Add after:=Worksheets(Worksheets.Count) ' ADDED
counter = 1
rowOffset = 0
Cells(1, 1).Select ' CHANGED to start at A1 change this to wherever you want the output to start (it will be in a separate sheet)
Do While staffMember(counter, 1) <> ""
Selection.Offset(rowOffset, 0) = staffMember(counter, 1)
Selection.Offset(rowOffset + 1, 0) = "Sick"
Selection.Offset(rowOffset + 1, 0).Interior.ColorIndex = 6
Selection.Offset(rowOffset + 1, 1) = staffMember(counter, 3)
Selection.Offset(rowOffset + 2, 0) = "Vacation"
Selection.Offset(rowOffset + 2, 0).Interior.ColorIndex = 7
Selection.Offset(rowOffset + 2, 1) = staffMember(counter, 4)
Selection.Offset(rowOffset + 3, 0) = "Unexcused"
Selection.Offset(rowOffset + 3, 0).Interior.ColorIndex = 3
Selection.Offset(rowOffset + 3, 1) = staffMember(counter, 2)
counter = counter + 1
rowOffset = rowOffset + 5
Loop
End Sub
[Code End]
Thre is a good book by John WalkenBach that you might want to invest in. "EXCEL 2000 Power Programming in VBA"
ISBN 076453263-4
PS Yes the code should be in a module but you could easily have it running from a command button embedded in the worksheet.
I have marked the ADDED lines of code
Chas
Thanks again for the help. lol yeah I should have posted that to begin with lol. Sorry bout that =)
One more question for ya. You said that GS & PM would be treated as one employee. How do I split them later on? (PM is a trainee and will be working alone eventually.)
I tried the code and all I get is a run-time error =S
Here is the error and what it points to when I debug
Run-time error '1004'
Select Method of Worksheet Class Failed
Dim ws As Integer ' ADDED
staffCount = 10
lastAddPos = 0
For ws = 1 To Worksheets.Count ' ADDED -
Worksheets(ws).Select ' ADDED -
'ReDim staffMember(staffCount, 4) ' REMOVED
For Each cell In Range("A1:A100") ' CHANGE THIS RANGE TO WHATEVER SUITS YOU
staffMemberFound = False
colour = cell.Interior.ColorIndex
staffName = cell.Value
Select Case colour
Case 3 ' red
colourOffset = 2
Case 6 ' yellow
colourOffset = 3
Case 7 ' rose
colourOffset = 4
End Select
I put the code into a module and ran it on a blank sheet at the end. I also tried to run it while on the first sheet and still had the same results. What did I do wrong?
Ok never mind about my previous post. I think I fixed it (had a hidden sheet I forgot about)
Now I'm comming up with a diffrent error
Run-time error '9':
Subscript out of range
staffMember(staffIndex, colourOffset) = staffMember(staffIndex, colourOffset) + 1
' increment the appropriate array elements
Now what did I goof on?
