Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 02-15-2019, 05:27 PM
Marcia's Avatar
Marcia Marcia is offline Macro to add "Sick" in a monitoring form for learners Windows 7 32bit Macro to add "Sick" in a monitoring form for learners Office 2007
Expert
Macro to add "Sick" in a monitoring form for learners
 
Join Date: May 2018
Location: Philippines
Posts: 526
Marcia has a spectacular aura aboutMarcia has a spectacular aura aboutMarcia has a spectacular aura about
Default 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.
Attached Files
File Type: xlsm AddSick.xlsm (202.1 KB, 9 views)
Reply With Quote
  #2  
Old 10-17-2019, 02:38 PM
Marcia's Avatar
Marcia Marcia is offline Macro to add &quot;Sick&quot; in a monitoring form for learners Windows 7 32bit Macro to add &quot;Sick&quot; in a monitoring form for learners Office 2013
Expert
Macro to add &quot;Sick&quot; in a monitoring form for learners
 
Join Date: May 2018
Location: Philippines
Posts: 526
Marcia has a spectacular aura aboutMarcia has a spectacular aura aboutMarcia has a spectacular aura about
Default

The complete code is found in:
https://www.msofficeforums.com/excel...e-morning.html
Reply With Quote
Reply

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
Macro to add &quot;Sick&quot; in a monitoring form for learners Enable "check spelling as you type" for Form Fields zeroth Word 3 11-08-2012 08:57 AM
Macro to add &quot;Sick&quot; in a monitoring form for learners 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

Other Forums: Access Forums

All times are GMT -7. The time now is 06:07 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft