Sub fullTT()
Dim classNamesA(1 To 20) As String
Dim classNamesB(1 To 20) As String
classNamesA(1) = "4 HUM 4 LAT"
classNamesB(1) = "4 ASO"
classNamesA(2) = "5 HUM 5 LAT-MT 6 LAT-MT"
classNamesB(2) = "3de Graad"
classNamesA(3) = "3 HUM 3 LAT"
classNamesB(3) = "3 ASO"
classNamesA(4) = "6 LAT-MT"
classNamesB(4) = "6 ASO"
classNamesA(5) = "5 HUM 5 LAT-MT"
classNamesB(5) = "5 ASO"
classNamesA(6) = "2A KT 2A MT-W"
classNamesB(6) = "2A"
classNamesA(7) = "1A1 1A2 2A MT-W 2A KT"
classNamesB(7) = "1ste Graad"
classNamesA(8) = "1A1 1A2 2A KT 2A MT-W"
classNamesB(8) = "1ste Graad"
classNamesA(9) = "3 HUM 3 LAT 4 HUM 4 LA"
classNamesB(9) = "2de/3de Graad"
classNamesA(10) = "3 HUM 6 LAT-MT 4 LAT 5 L"
classNamesB(10) = "2de/3de Graad"
classNamesA(11) = "3 HUM 3 LAT 4 HUM 4 LA"
classNamesB(11) = "2de Graad"
classNamesA(12) = "1A1 1A2"
classNamesB(12) = "1A"
classNamesA(13) = "1A1 1A2 2A KT 2A MT-W"
classNamesB(13) = ""
classNamesA(14) = "5 LAT-MT"
classNamesB(14) = "5 LAT"
classNamesA(15) = "1A1 6 LAT-MT 4 LAT 3 HU"
classNamesB(15) = ""
classNamesA(16) = "5 LAT-MT 6 LAT-MT"
classNamesB(16) = "5/6 LAT"
Dim nameHeaderFont As String: nameHeaderFont = "Alegreya Sans ExtraBold"
Dim nameHeaderSize As Integer: nameHeaderSize = 12
Dim dayTimeFont As String: dayTimeFont = "Alegreya Sans Medium"
Dim dayTimeSize As Integer: dayTimeSize = 9
Dim tableFont As String: tableFont = "Alegreya Medium"
Dim tableFontSize As Integer: tableFontSize = 9
Dim misFont As String: misFont = "Alegreya SC ExtraBold"
Dim misFontSize As Integer: misFontSize = 10
Dim lunchFont As String: lunchFont = "Alegreya Sans SC ExtraBold"
Dim lunchFontSize As Integer: lunchFontSize = 10
Dim breakFont As String: breakFont = "Alegreya Sans SC ExtraBold"
Dim breakFontSize As Integer: breakFontSize = 10
Dim nameHeaderHeight As Integer: nameHeaderHeight = 25
Dim dayRowHeight As Integer: dayRowHeight = 13
Dim lessonBlockHeight As Integer: lessonBlockHeight = 29
Dim breakRowHeight As Integer: breakRowHeight = 13
Dim timeColWidth As Integer: timeColWidth = 4.5
Dim dayColWidth As Integer: dayColWidth = 9.5
Dim spacerRowHeight As Integer: spacerRowHeight = 15
Dim bkgrOrng As Double: bkgrOrng = 0.799981688894314
Dim subheadOrng As Double: subheadOrng = 0.599993896298105
Dim brkRowTint As Double: brkRowTint = -0.249946592608417
Dim LogoFile As String: LogoFile = "G:\Shared drives\Sint-Ignatius ICT Admin\Style Guide\Logos\PNG\SI Logo@0.5x.png"
Dim ThemeFile As String: ThemeFile = "G:\Shared drives\Sint-Ignatius ICT Admin\Style Guide\Templates\Themes\Document Theme\Sint-Ignatius.thmx"
Dim lkInits() As Variant: lkInits = VBA.Array("", "BTH", "BHU", "DDU", "DHE", "DKE", "EGO", "FLE", "GAR", "HOV", "IPI", "LST", "MHLE", "MSU", "GVE", "SWU", "RRE", "SME", "TDI", "XFI")
Dim fmtRng As Range: Set fmtRng = Range("B3:T15, B20:T32, B37:T49, B54:T66, B71:T83")
Dim dayHeader As Range: Set dayHeader = Range("A1:U1, A18:U18, A35:U35, A52:U52, A69:U69")
Dim breakRow As Range: Set breakRow = Range("B6:T6, B10:T10, B13:T13, B20:T20, B23:T23, B27:T27, B30:T30, B37:T37, B40:T40, B44:T44, B47:T47, B54:T54, B57:T57, B61:T61, B64:T64, B71:T71, B74:T74")
Dim lkNames As Range: Set lkNames = Range("A2:T2, A19:T19, A36:T36, A53:T53, A70:T70")
Dim lunchRow As Range: Set lunchRow = Range("B9:T9, B26:T26, B43:T43, B60:T60")
Dim misCell As Range: Set misCell = Range("B32:T32")
Dim timeCol As Range: Set timeCol = Range("A2:A15, A19:A32, A36:A49, A53:A66, A70:A83")
Dim spacerRow As Range: Set spacerRow = Range("A17:U17, A34:U34, A51:U51, A68:U68")
Dim deleteRows As Range: Set deleteRows = Range("3:5, 16:16, 33:33, 50:50, 67:67, 77:87")
Dim timeFill() As Variant: timeFill = Application.Transpose(Array("", "8:00", "8:20", "9:10", "10:00", "10:20", "11:10", "12:00", "12:30", "13:00", "13:50", "14:40", "15:00", "15:50"))
Application.DisplayAlerts = False
ActiveWorkbook.ApplyTheme (ThemeFile)
ActiveSheet.Name = "ALG"
For Each c In fmtRng
If c.MergeArea.Columns.Count > 1 Then
If c.MergeArea.Cells(1) = "" Or c.MergeArea.Cells(1) = "pauze" Then
c.MergeArea.UnMerge
End If
End If
Next
Dim r As Range
For Each r In timeCol.Areas
r.Value = timeFill
r.Offset(, 20).Value = timeFill
Next
lunchRow.Value = "Lunch"
lunchRow.MergeCells = True
misCell.Value = "MIS"
misCell.MergeCells = True
lkNames.Value = lkInits
Range("A1").Value = "maandag"
Range("A18").Value = "dinsdag"
Range("A35").Value = "woensdag"
Range("A52").Value = "donderdag"
Range("A69").Value = "vrijdag"
dayHeader.MergeCells = True
Dim StartPosition As Integer
Dim CompareResult As Integer
Dim CourseName As String
For Each cell In fmtRng
cell.Value = Application.WorksheetFunction.Trim(cell.Value)
If cell.Value = "TOEZ. pauze" Then
cell.Value = "TOEZ"
ElseIf Len(cell) > 5 Then
For i = 1 To UBound(classNamesA)
sp = Split(cell.Value, Chr(10))
If UBound(sp) = 1 Then
If sp(1) = classNamesA(i) Then
CourseName = sp(0)
Select Case CourseName
Case "MIS": cell.Value = CourseName
Case "GODS": cell.Value = CourseName & Chr(10) & IIf(i = 9, classNamesB(11), classNamesB(i))
Case Else: cell.Value = CourseName & Chr(10) & classNamesB(i)
End Select
End If
End If
Next i
End If
Next
For Each cell In Range("L3:L85")
If cell.Value = "" Then
cell.Interior.ThemeColor = xlThemeColorAccent4
cell.Interior.TintAndShade = subheadOrng
End If
Next
Range("L8").Value = "(1A2 FRA /" & vbCrLf & "5 ASO NED)"
Range("L11").Value = "(1A1 FRA)"
Range("L12").Value = "(1A2 NED)"
Range("L14").Value = "(4 ASO NED)"
Range("L15").Value = "(1A1 NED /" & vbCrLf & "4 ASO NED)"
Range("L24").Value = "(1A2 NED)"
Range("L29").Value = "(1A1 NED)"
Range("L31").Value = "(4 ASO NED)"
Range("L39").Value = "(1A1 FRA /" & vbCrLf & "4 ASO NED)"
Range("L41").Value = "(1A2 FRA)"
Range("L42").Value = "(1A1 NED /" & vbCrLf & "1A2 FRA)"
Range("L45").Value = "(4 ASO FRA /" & vbCrLf & "5 ASO NED)"
Range("L46").Value = "(4 ASO FRA /" & vbCrLf & "5 ASO NED)"
Range("L48").Value = "(1A2 NED)"
Range("L49").Value = "(1A2 NED)"
Range("L55").Value = "(1A2 FRA)"
Range("L56").Value = "(4 ASO NED)"
Range("L58").Value = "(1A1 NED /" & vbCrLf & "4 ASO FRA)"
Range("L59").Value = "(4 ASO FRA)"
Range("L72").Value = "(1A1 FRA)"
Range("L73").Value = "(1A1 FRA /" & vbCrLf & "1A2 NED)"
Range("L75").Value = "(5 ASO NED)"
Range("L76").Value = "(1A1 NED /" & vbCrLf & "5 ASO NED)"
With lkNames
.Interior.ThemeColor = xlThemeColorDark2
.Interior.TintAndShade = subheadOrng
.Font.Name = dayTimeFont
.Font.Size = dayTimeSize
.Font.ThemeColor = xlThemeColorLight2
.ColumnWidth = dayColWidth
.RowHeight = dayRowHeight
End With
Set timeCol = Range("A2:A85, U2:U85")
With timeCol
.Interior.ThemeColor = xlThemeColorDark2
.Interior.TintAndShade = subheadOrng
.Font.Name = dayTimeFont
.Font.Size = dayTimeSize
.Font.ThemeColor = xlThemeColorLight2
.ColumnWidth = timeColWidth
End With
With dayHeader
.Interior.ThemeColor = xlThemeColorDark2
.Font.Name = nameHeaderFont
.Font.Size = nameHeaderSize
.Font.ThemeColor = xlThemeColorLight2
.RowHeight = nameHeaderHeight
End With
With fmtRng
.Font.Name = tableFont
.Font.Size = tableFontSize
.Font.ThemeColor = xlThemeColorLight1
.RowHeight = lessonBlockHeight
End With
With misCell
.Interior.ThemeColor = xlThemeColorDark2
.Interior.TintAndShade = subheadOrng
.Font.Name = misFont
.Font.Size = misFontSize
.Font.ThemeColor = xlThemeColorLight2
.RowHeight = breakRowHeight
End With
With lunchRow
.Interior.ThemeColor = xlThemeColorDark2
.Interior.TintAndShade = subheadOrng
.Font.Name = lunchFont
.Font.Size = lunchFontSize
.Font.ThemeColor = xlThemeColorLight2
.RowHeight = breakRowHeight
End With
fmtRng.FormatConditions.Add Type:=xlExpression, Formula1:="=isblank(b3)=true"
fmtRng.FormatConditions(fmtRng.FormatConditions.Count).SetFirstPriority
With fmtRng.FormatConditions(1)
.Interior.ThemeColor = xlThemeColorDark2
.Interior.TintAndShade = bkgrOrng
.StopIfTrue = False
End With
With breakRow
.RowHeight = breakRowHeight
.FormatConditions.Add Type:=xlExpression, Formula1:="=isblank(b6)=true"
breakRow.FormatConditions(breakRow.FormatConditions.Count).SetFirstPriority
With breakRow.FormatConditions(1)
.Interior.ThemeColor = xlThemeColorDark1
.Interior.TintAndShade = brkRowTint
.StopIfTrue = False
End With
End With
With spacerRow
.Interior.ColorIndex = 0
.RowHeight = spacerRowHeight
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
End With
deleteRows.Delete shift:=xlUp
Set fmtRng = Range("A1:U12, A14:U28, A30:U44, A46:U60, A62:U69")
With fmtRng
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.Borders(xlInsideHorizontal).ThemeColor = 4
.Borders(xlInsideVertical).ThemeColor = 4
.Borders(xlEdgeLeft).ThemeColor = 4
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeRight).ThemeColor = 4
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeTop).ThemeColor = 4
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).ThemeColor = 4
.Borders(xlEdgeBottom).Weight = xlMedium
End With
Dim wbPath As String
Dim fileName As String
Dim deleteMiddle As String
Dim fileArray() As String
Dim fileYear As String
Dim fileMonth As String
Dim fileVersion As String
Dim fileMonthNumber As Integer
Dim fileMonthFormat As String
Dim lFooter As String
Dim shTitle As String
wbPath = ActiveWorkbook.Path
fileName = Mid(Replace(ActiveWorkbook.FullName, wbPath, ""), 2)
deleteMiddle = Replace(Replace(fileName, " ", "", InStr(InStr(InStr(1, fileName, " ") + 1, fileName, " ") + 1, fileName, " "), 1), Mid(fileName, InStr(1, fileName, ".")), "")
For i = 1 To Len(deleteMiddle)
If deleteMiddle Like "*R#*" Then
deleteMiddle = Left(deleteMiddle, Len(deleteMiddle) - 1)
ElseIf deleteMiddle Like "*R" Then
deleteMiddle = Left(deleteMiddle, Len(deleteMiddle) - 1)
End If
Next
fileName = Replace(Replace(fileName, " " & deleteMiddle, "."), Mid(fileName, InStr(1, fileName, "_"), Len(Mid(fileName, InStr(1, fileName, "_"), InStr(1, fileName, ".xlsx")))), "")
fileArray = Split(fileName, " ", 4)
fileYear = fileArray(0)
fileMonth = fileArray(1)
fileVersion = Mid(fileArray(2), 2)
fileMonthNumber = Month(DateValue("1 " & fileMonth & " 2022"))
If fileMonthNumber > 8 Then
fileYear = "20" & Left(fileYear, 2)
Else: fileYear = "20" & Right(fileYear, 2)
End If
fileMonthFormat = Format(fileMonthNumber, "00")
lFooter = "v." & fileYear & "/" & fileMonthFormat & "." & fileVersion & "-"
shTitle = "Algemeen Uurrooster"
ActiveSheet.HPageBreaks.Add before:=Cells(35, 1)
With ActiveSheet.PageSetup
.Orientation = xlLandscape
.PaperSize = xlPaperA3
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.LeftMargin = Application.CentimetersToPoints(1.25)
.RightMargin = Application.CentimetersToPoints(1.25)
.TopMargin = Application.CentimetersToPoints(1.25)
.BottomMargin = Application.CentimetersToPoints(1.25)
.HeaderMargin = Application.CentimetersToPoints(0.5)
.FooterMargin = Application.CentimetersToPoints(0.5)
.CenterVertically = True
.CenterHorizontally = True
.CenterHeader = "&""Alegreya""&9&K000000" & "Fold and attach here"
.LeftFooter = "&""Alegreya""&9&K000000" & lFooter & "&A"
.LeftHeaderPicture.fileName = LogoFile
.LeftHeaderPicture.Height = 55.5
.LeftHeader = "&G"
.CenterHeader = "&""Alegreya Sans SC ExtraBold""&18&K354896" & shTitle
.CenterFooter = "&""Alegreya""&9&K000000" & "Fold and attach here"
End With
fileName = wbPath & "\" & fileArray(0) & " " & fileArray(1) & " v." & fileVersion & "_ALG.xlsx"
ActiveWorkbook.SaveAs fileName
Application.DisplayAlerts = True
End Sub