#1
|
||||
|
||||
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 |
#2
|
||||
|
||||
The complete code is found in:
https://www.msofficeforums.com/excel...e-morning.html |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
use "Text Form Field" to create word Leitner Box | taherkhani | Word | 1 | 12-10-2014 11:36 PM |
remove repeated words with " macro " or " wild cards " in texts with parentheses and commas | jocke321 | Word VBA | 2 | 12-10-2014 11:27 AM |
Enable "check spelling as you type" for Form Fields | zeroth | Word | 3 | 11-08-2012 08:57 AM |
How to choose a "List" for certain "Heading" from "Modify" tool? | Jamal NUMAN | Word | 2 | 07-03-2011 03:11 AM |
Monitoring "Record Narration"? | knewman | PowerPoint | 1 | 04-23-2011 04:59 PM |