Sub StuUpdate()Dim Ray As Variant, n As Long, sht As Worksheet, Ac As Long, Num As Long
Dim S As Variant, P As Variant, V As Variant, H As Variant, Q As Variant
Dim Dic As Object
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each sht In Worksheets
If InStr(sht.Name, "_") > 0 Then
Ray = sht.UsedRange
For n = 4 To UBound(Ray, 1)
If Not Dic.Exists(Ray(n, 1)) Then
ReDim S(1 To 1500): S(1) = "Sick Days"
ReDim E(1 To 1500): E(1) = "Early Leave Days"
ReDim L(1 To 1500): L(1) = "Late Arrival Days"
ReDim V(1 To 1500): V(1) = "Vacation Days"
ReDim H(1 To 1500): H(1) = "Half Days"
ReDim M(1 To 1500): M(1) = "Late In Early out"
Dic.Add Ray(n, 1), Array(S, 1, E, 1, L, 1, V, 1, H, 1, M, 1)
Q = Dic(Ray(n, 1))
For Ac = 2 To UBound(Ray, 2)
If Not IsEmpty(Ray(n, Ac)) Then
Select Case Ray(n, Ac)
Case "S": Q(1) = Q(1) + 1: Q(0)(Q(1)) = Dt(sht, CLng(Ray(3, Ac)))
Case "E": Q(3) = Q(3) + 1: Q(2)(Q(3)) = Dt(sht, CLng(Ray(3, Ac)))
Case "L": Q(5) = Q(5) + 1: Q(4)(Q(5)) = Dt(sht, CLng(Ray(3, Ac)))
Case "V": Q(7) = Q(7) + 1: Q(6)(Q(7)) = Dt(sht, CLng(Ray(3, Ac)))
Case "H": Q(9) = Q(9) + 1: Q(8)(Q(9)) = Dt(sht, CLng(Ray(3, Ac)))
Case "M": Q(11) = Q(11) + 1: Q(10)(Q(11)) = Dt(sht, CLng(Ray(3, Ac)))
End Select
End If
Next Ac
Dic(Ray(n, 1)) = Q
Else
Q = Dic(Ray(n, 1))
For Ac = 2 To UBound(Ray, 2)
If Not IsEmpty(Ray(n, Ac)) Then
Select Case Ray(n, Ac)
Case "S": Q(1) = Q(1) + 1: Q(0)(Q(1)) = Dt(sht, CLng(Ray(3, Ac)))
Case "E": Q(3) = Q(3) + 1: Q(2)(Q(3)) = Dt(sht, CLng(Ray(3, Ac)))
Case "L": Q(5) = Q(5) + 1: Q(4)(Q(5)) = Dt(sht, CLng(Ray(3, Ac)))
Case "V": Q(7) = Q(7) + 1: Q(6)(Q(7)) = Dt(sht, CLng(Ray(3, Ac)))
Case "H": Q(9) = Q(9) + 1: Q(8)(Q(9)) = Dt(sht, CLng(Ray(3, Ac)))
Case "M": Q(11) = Q(11) + 1: Q(10)(Q(11)) = Dt(sht, CLng(Ray(3, Ac)))
End Select
End If
Next Ac
Dic(Ray(n, 1)) = Q
End If
Next n
End If
Next sht
Dim K As Variant, c As Long, cc As Long, oMax As Long
Application.ScreenUpdating = False
[COLOR=#ff0000][B]For Each K In Dic.keys[/B][/COLOR]
[COLOR=#ff0000][B] cc = 0[/B][/COLOR]
[COLOR=#ff0000][B] If Not K = "" Then[/B][/COLOR]
[COLOR=#ff0000][B] On Error Resume Next[/B][/COLOR]
Set sht = ActiveWorkbook.Sheets(K)
If Not Err = 0 Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = K
End If
'Change Position of text and Alignment
'to suit Between Bands Hash bands
'###############
With Sheets(K)
.Range("A15").Resize(500, 100).ClearContents
.Range("b13") = K ' This is Student Name, remove if not wanted
.Range("A7") = Format(Now, "MMMM,d,yyyy")
.Range("A10").Value = "Student Attendance Record"
.Range("A10:B10").Merge
.Range("A7:B7").Merge
.Range("A7").Font.Size = 16
.Range("A7").Font.Bold = True
.Range("A13").Value = "Student Name:"
.Range("A14").Value = "Date of Birth:"
.Range("A15").Value = "Admission Date:"
.Range("A16").Value = "Discharge Date:"
.Range("A7:b16").Font.Size = 12
.Range("A7:b16").Font.Bold = True
.Range("A13:A16").HorizontalAlignment = xlLeft
.Range("A7").HorizontalAlignment = xlLeft
'##########
For n = 0 To 10 Step 2 ' added items from dict Now 10 was 7
cc = cc + 1
oMax = Application.Max(oMax, Dic(K)(n + 1))
For c = 1 To Dic(K)(n + 1)
.Cells(c + 18, cc) = Dic(K)(n)(c) 'NB:- Start Od Dates shown Here as C+18
Next c
Next n
'############# Alter below as required
.Columns("A:A").ColumnWidth = 17
.Columns("B:B").ColumnWidth = 14
.Columns("C:C").ColumnWidth = 14
.Columns("D:D").ColumnWidth = 14
.Columns("E:E").ColumnWidth = 14
.Columns("F:F").ColumnWidth = 14
.Range("A19").Resize(oMax + 18, 6).HorizontalAlignment = xlCenter
'###################
Call ****(Sheets(K))
End With
End If
Next K
Application.ScreenUpdating = True
End Sub
Function Dt(sh As Object, Num As Long) As Date
Dim n As Long
For n = 1 To 12
If MonthName(n) = Split(sh.Name, "_")(0) Then
Dt = DateSerial(Split(sh.Name, "_")(1), n, Num)
Exit For
End If
Next n
End Function
Sub ****(sht As Object)
Dim Pic As Picture, Fd As Boolean
For Each Pic In sht.Pictures
Fd = True
Next Pic
If Not Fd Then
Application.ScreenUpdating = False
'Change path of your image to suit
'My path:-
' Set Pic = sht.Pictures.Insert("C:\Users\USER1\Desktop\thP2Y8R8D3.jpg")
Set Pic = sht.Pictures.Insert("C:\Users\Inigo Montoya\Desktop\Capture44.JPG")
With sht.Range("A1")
Pic.Top = .Top ' NB The Object is "Pic" not Picture !!
Pic.Left = .Left
Pic.LockAspectRatio = msoTrue ' I found when this was Locked I could not change the Picture size !!!
'Pic.Height = 80
End With
Application.ScreenUpdating = True
Else
Exit Sub
End If
End Sub
