Macro to add "Sick" in a monitoring form for learners
Hi, here's another request from the happy users of the below code that this Forum helped develop. Would somebody please add code for "Sick". If a learner calls in sick, the mark is "S", colored green triangle. In the macro formula for total absences, it should include the "Sick" since the learner is absent. I tried inserting codes for "Sick" but no such luck. If I type "S" in the attached form and click update triangles, it the cell should be colored green and the total abasences chould be updated but it's not working. I deleted many lines in the script dictionary to save on space and I transferred this thread originally from "Excel".
Code:
Sub AddTriangle(myCell, ampm, Infraction, Size)
ampm = UCase(ampm)
'AddShape( _Type_ , _Left_ , _Top_ , _Width_ , _Height_ )
Set myshape = ActiveSheet.Shapes.AddShape(msoShapeRectangle, myCell.Left + 1 + IIf(ampm = "PM", myCell.Width * (1 - Size), 0), myCell.Top + IIf(ampm = "PM", myCll + myCell.Height * (1 - Size), 0), myCell.Width * Size, myCell.Height * Size)
If Size < 1 Then myshape.ZOrder msoBringToFront Else myshape.ZOrder msoSendToBack
Set yyy = myshape.Nodes
If ampm = "AM" Then
yyy.Delete (3) 'delete bottom right node
Else
yyy.Delete (5)
yyy.Delete (1)
End If
Select Case UCase(Infraction)
Case "LATE"
myshape.Fill.ForeColor.RGB = 16711680 'blue
Case "CUTTING"
myshape.Fill.ForeColor.RGB = 255 'red
Case "SICK"
myshape.Fill.ForeColor.RGB = 100 'green
End Select
myshape.Line.Visible = msoFalse
End Sub
Sub blah()
'The printed form will show only the Xes and the shades for late, sick and cutting classes.
'Do totals on a row by row basis too?
Set dict = CreateObject("Scripting.Dictionary")
PopulateDictionary dict
z = dict("trimmed in-cell") 'the headers.
ChangeToIndx = Application.Match("change to", z, 0) - 1
Set rngtocheck = Range("D13:AA73")
'clear triangles:
For Each shp In ActiveSheet.Shapes
If shp.Type <> msoFormControl Then
If Not Intersect(shp.TopLeftCell, rngtocheck) Is Nothing Then shp.Delete
End If
Next shp
'new triangles:
For Each rw In rngtocheck.Rows
ThisRowAbsenceCount = 0: ThisRowLateCount = 0: ThisRowHasDottedDiagonal = False
For Each cll In rw.Cells
'Debug.Assert cll.Address <> "$D$13"
'cll.Select
If cll.Borders(xlDiagonalUp).LineStyle <> xlNone Then 'only process cells which have a diagonal line.
ThisRowHasDottedDiagonal = True
cll.Font.Color = vbWhite 'white font
If Not cll.HasFormula Then 'only process those cells with no formula (it's been overwritten by the user).
'Stop 'Stuff to check:
'TI and LE don't both exist together
'treat likes of XX, LL, CC, SS as if space between
'perhaps remove LE and TI replace with spaces, trim, then if more than one space error/ambiguous (remember valid leading space).
CellValue = cll.Value
TrimmedCellValue = Application.Trim(UCase(Replace(Replace(CellValue, "/", ""), Chr(160), " ")))
If Left(Replace(CellValue, Chr(160), " "), 1) = " " Then TrimmedCellValue = " " & TrimmedCellValue
If dict.exists(TrimmedCellValue) Then ' it is one of the dictionary entries:
x = dict(TrimmedCellValue)
If CellValue <> x(ChangeToIndx) Then cll.Value = x(ChangeToIndx) 'replaces the user's input with a standardised input.
'Stop
EmbellishCell cll, x, z, ThisRowAbsenceCount, ThisRowLateCount, ThisRowSickCount
zz = cll.Value
j = 1
If x(0) = True Then 'absence AM
If Len(zz) > 4 Then cll.Font.Size = 7
j = InStr(j, zz, "X", vbTextCompare)
With cll.Characters(Start:=j, Length:=1).Font
.ColorIndex = xlAutomatic
.Size = 14
.Superscript = True
End With
End If
If x(4) = True Then 'absence PM
If Not x(0) = True And Len(zz) > 4 Then cll.Font.Size = 7
j = InStr(j + 1, zz, "X", vbTextCompare)
With cll.Characters(Start:=j, Length:=1).Font
.ColorIndex = xlAutomatic
.Size = 14
.Subscript = True
End With
End If
Else 'it is not one of the dictionary entries:
'do some more delving
'and highlight those cells which we don't know how to interpret:
cll.Interior.Color = 65535
End If 'dict.exists(TrimmedCellValue)
End If 'has formula
End If ' has diagonal
cll.Errors(xlUnlockedFormulaCells).Ignore = True 'removes some green error triangles
Next cll
'add totals absences/lates:
If ThisRowHasDottedDiagonal Then
Cells(rw.Row, "AC").Value = ThisRowAbsenceCount
Cells(rw.Row, "AD").Value = ThisRowLateCount
End If
Next rw
End Sub
Sub ResetMe() 'clear triangles,visible fonts
Set rngtocheck = Range("D13:AA73")
Application.ScreenUpdating = False
For Each shp In ActiveSheet.Shapes
If shp.Type <> msoFormControl Then
If Not Intersect(shp.TopLeftCell, rngtocheck) Is Nothing Then shp.Delete
End If
Next shp
For Each cll In rngtocheck.Cells 'Selection.Cells
With cll
'.Select
If .Borders(xlDiagonalUp).LineStyle <> xlNone Then 'only process cells which have a diagonal line.
'automatic font colour
'centre align
'standard font size
'remove sub/superscript
With .Font
.Name = "Arial Narrow"
.Size = 11
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Bold = True
.Superscript = False
.Subscript = False
End With
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
End If
End With
cll.Errors(xlUnlockedFormulaCells).Ignore = True
Next cll
Application.ScreenUpdating = True
End Sub
Sub PrintTable() 'creates a sheet with the dictionary items for review.
Set dict = CreateObject("Scripting.Dictionary")
PopulateDictionary dict
'x = dict("C")
Set newsht = Sheets.Add(after:=Sheets(Sheets.Count))
newsht.Range("A1").Resize(dict.Count) = Application.Transpose(dict.keys)
Set Destn = newsht.Range("B1")
For Each dictItem In dict.items
Destn.Resize(, 8) = dictItem
Set Destn = Destn.Offset(1)
Next dictItem
newsht.ListObjects.Add xlSrcRange, newsht.Range("A1").CurrentRegion, , xlYes
newsht.Columns("A:I").EntireColumn.AutoFit
End Sub
Sub PopulateDictionary(d)
'ChrW(8195) 'm space
'ChrW(8194) 'n space
'include empty cell in this?
d("trimmed in-cell") = Array("Absent AM", "Late AM", "Cutting AM", "SICK AM", "Other", "Absent PM", "Late PM", "Cutting PM", "SICK PM", "change to")
d("X") = Array("TRUE", "", "", "", "", "", "", "", "", "X" & String(3, Chr(160))) 'non-breaking spaces
d(" X") = Array("", "", "", "", "", "TRUE", "", "", "", " X")
d("S") = Array("", "", "", "TRUE", "", "", "", "", "", "S")
d(" S") = Array("", "", "", "", "", "", "", "", "TRUE", " S")
d("XX") = Array("TRUE", "", "", "", "TRUE", "", "", "X X")
d("SS") = Array("", "", "", "TRUE", "", "", "", "", "TRUE", "S S")
d("X X") = Array("TRUE", "", "", "", "TRUE", "", "", "X X")
d("X L") = Array("TRUE", "", "", "", "", "TRUE", "", "X L")
d("XL") = Array("TRUE", "", "", "", "", "TRUE", "", "X L")
d("X C") = Array("TRUE", "", "", "", "", "", "TRUE", "X C")
d("XC") = Array("TRUE", "", "", "", "", "", "TRUE", "X C")
d("XLC") = Array("TRUE", "", "", "", "", "TRUE", "TRUE", "X LC")
d("X LC") = Array("TRUE", "", "", "", "", "TRUE", "TRUE", "X LC")
End Sub
Sub EmbellishCell(cll, x, z, Absences, Lates, Sick)
CuttingSizeAM = 1: CuttingSizePM = 1
If x(Application.Match("Absent AM", z, 0) - 1) = True Then Absences = Absences + 0.5
If x(Application.Match("Absent PM", z, 0) - 1) = True Then Absences = Absences + 0.5
If x(Application.Match("Late AM", z, 0) - 1) = True Then
AddTriangle cll, "AM", "LATE", 1
Lates = Lates + 1
CuttingSizeAM = 0.5
End If
If x(Application.Match("Late PM", z, 0) - 1) = True Then
AddTriangle cll, "PM", "LATE", 1
Lates = Lates + 1
CuttingSizePM = 0.5
End If
If x(Application.Match("Cutting AM", z, 0) - 1) = True Then
AddTriangle cll, "AM", "CUTTING", CuttingSizeAM
Absences = Absences + 0.5
End If
If x(Application.Match("Cutting PM", z, 0) - 1) = True Then
AddTriangle cll, "PM", "CUTTING", CuttingSizePM
Absences = Absences + 0.5
End If
If x(Application.Match("Sick AM", z, 0) - 1) = True Then
AddTriangle cll, "AM", "SICK", CuttingSizeAM
Absences = Absences + 0.5
End If
If x(Application.Match("Sick PM", z, 0) - 1) = True Then
AddTriangle cll, "PM", "SICK", CuttingSizePM
Absences = Absences + 0.5
End If
End Sub
Function CountOfRowsWithNOrMoreConsecutiveXs(myRange, N)
Vals = myRange.Value
For rw = 1 To UBound(Vals)
ThisRowCount = 0
For colm = 1 To UBound(Vals, 2)
If InStr(1, UCase(Vals(rw, colm)), "X") > 0 Then ThisRowCount = ThisRowCount + 1 Else ThisRowCount = 0
If ThisRowCount >= N Then
RowCount = RowCount + 1
Exit For
End If
Next colm
Next rw
CountOfRowsWithNOrMoreConsecutiveXs = RowCount
End Function
Thank you.
|