Szkoła policealna rządzi się swoimi prawami – zajęcia odbywają się w tzw. „blokach”. Program PLANSP próbuje opanować chaos, jaki mógłby wkraść się w zupełnie inne podejście do układania planu lekcji. W związku z tym, że to właśnie ja zajmuję się układaniem planów dla szkoły policealnej, dlatego też program jest prosty, efektywny i nie musi być wyposażony w różnorodne zabezpieczenia – ja wiem, jak go nie zepsuć! Najważniejsza jest informacja o ilości zajęć do odbycia, wolnych miejscach i drukowanie różnorodnych zestawień: dla studentów, nauczycieli, listy obecności, itp.
mgr inż. Wacław Libront
Niewiele programowania i prawie "zero" formuł w arkuszu. Już jakiś czas temu stwierdziłem, że bezpieczniej jest (niekoniecznie wygodniej) jeśli arkusz nie będzie zawierał formuł, ale wszystko obliczone zostanie za pomocą makropoleceń i wyświetlone dla użytkownika w odpowiednich komórkach.
Ciekawostki z kodu:
- pokazywanie i chowanie kolumn (Sub ZerowePrzedmiotyChowaj())
- funkcja wyszukaj.pionowo() tym razem za pomocą funkcji VB (Function NazwaPrzedmiotu(skr As Variant) As Variant)
- bardzo skomplikowane drukowanie różnorodnych planów zajęć (Sub DrukujListęRD(w, k As Variant))Sub DrukujRozkładN(nau, m1, m2 As Variant)
'wykorzystane w planach nauczania
Sub SchowajCzwartki()
For w = 7 To 136 Step 3
Rows(w).RowHeight = 0
Next w
End Sub
Sub PokażCzwartki()
For w = 7 To 136 Step 3
Rows(w).RowHeight = 15
Next w
End Sub
'pokaż wszystkie
Sub ZerowePrzedmiotyPokaż()
For k = 8 To 70
Columns(k).ColumnWidth = 2.6
If (k = 23) Or (k = 39) Or (k = 55) Then Columns(k).ColumnWidth = 4
Next k
End Sub
'jeśli w wierszy 3 i 4 jest zero
' to nie ma godzin i można całą kjolumnę schować
Sub ZerowePrzedmiotyChowaj()
For k = 8 To 70
g = Cells(3, k) + Cells(4, k)
p = Cells(1, k) & Cells(2, k)
If g > 0 Or p <> "" Then
Columns(k).ColumnWidth = 2.6
Else
Columns(k).ColumnWidth = 0
End If
If (k = 23) Or (k = 39) Or (k = 55) Then Columns(k).ColumnWidth = 4
Next k
End Sub
'wstawiamy skrót i otrzymujemy pełną nazwę przedmiotu
'arkusz STUD
Function NazwaPrzedmiotu(skr As Variant) As Variant
On Error GoTo błąd
s = Application.WorksheetFunction.VLookup(skr, _
Sheets("STUD").Range("B2:C50"), 2, False)
NazwaPrzedmiotu = s
Exit Function
błąd:
NazwaPrzedmiotu = ""
End Function
'drukuje listę z wybranego kursorem roku i dnia
Sub DrukujListę()
w = ActiveCell.Row
k = ActiveCell.Column
DrukujListęRD w, k
Sheets("razem").Select
End Sub
'drukuje cztery listy dla czterech kiedrunków z wybranego dnia
Sub DrukujListęDzień()
w = ActiveCell.Row
k = ActiveCell.Column
DrukujListęRD w, 7
DrukujListęRD w, 23
DrukujListęRD w, 39
DrukujListęRD w, 55
Sheets("razem").Select
End Sub
'drukujemy dla jednej daty D i wybranej grupy R
'parametrami są wybrany wiersz i kolumna
Sub DrukujListęRD(w, k As Variant)
'czyść
Sheets("OBEC").Select
Range("D3:J12").Select
Selection.ClearContents
Range("C14:J63").Select
Selection.ClearContents
Range("C4").Select
Rows("14:63").RowHeight = 16.5
Sheets("razem").Select
'w = ActiveCell.Row
'k = ActiveCell.Column
'1 od 7 kol i 15 kolumn
'2 - 23 do
rok = Int(((k - 7) / 16)) + 1
kol = (rok - 1) * 16 + 7 'pierwsza kolumna zawiera nazwę grupu i sumę godzin
dat = Cells(w, 1)
dty = Cells(w, 2)
Sheets("OBEC").Range("D3") = Cells(1, kol)
Sheets("OBEC").Range("D6") = dat
'studenci na listę
wi = 2
Do
student = Sheets("STUD").Cells(wi, kol)
Sheets("OBEC").Cells(wi + 12, 3) = student
wi = wi + 1
Loop Until Sheets("STUD").Cells(wi, kol) = ""
ko = 4 'od której kolumny zapisujemy w OBEC
wo = 7 'wiersz od którego zapisujemy znalezione przedmioty
For k1 = kol + 1 To kol + 15
ile = Cells(w, k1)
If ile > 0 Then 'zmalazło godziny
prz = Cells(1, k1) 'skrót przedmiotu
nau = Cells(2, k1) 'skrót nauczyciela
Sheets("OBEC").Cells(wo, 4) = prz
Sheets("OBEC").Cells(wo, 5) = nau
'a teraz trzeba znaleźć pełną nazwę
Sheets("OBEC").Cells(wo, 6) = NazwaPrzedmiotu(prz)
wo = wo + 1
For i = 1 To ile
Sheets("OBEC").Cells(11, ko) = ko - 3
Sheets("OBEC").Cells(12, ko) = prz
ko = ko + 1 'żeby pamiętało do następnego przedmiotu w tym dniu
Next i
End If
Next k1
'drukowanie
'sprawdzamy ile ukryć wierszy
wi = 64
Do
Sheets("OBEC").Rows(wi).RowHeight = 0
wi = wi - 1
Loop Until Sheets("OBEC").Cells(wi, 3) <> ""
Sheets("OBEC").Select
zakres = "$B$3:$J$63"
ActiveSheet.PageSetup.PrintArea = zakres
CzyPodgląd = Sheets("razem").Range("E5")
If CzyPodgląd = True Then
ActiveWindow.SelectedSheets.PrintPreview
Else
ActiveWindow.SelectedSheets.PrintOut Copies:=1
End If
Sheets("OBEC").Select
End Sub
'drukowanie rozkładu dla wybranego roku i okresu od do miesiąca
Sub DrukujRozkład()
w = ActiveCell.Row
k = ActiveCell.Column
'na wszelki wypadek
rok = 1
nau = "LW"
m_od = Range("E3")
m_do = Range("E4")
Sheets("DRUK").Select
Columns("A:D").Select
Selection.ClearContents
Range("B2").Select
Sheets("razem").Select
rok = Int(((k - 7) / 16)) + 1
nau = Cells(w, k)
If w = 1 Then
DrukujRozkładM rok, m_od, m_do
End If
If w = 2 Then
DrukujRozkładN nau, m_od, m_do
End If
If (w > 2) Or (rok = 0) Or (nau = "") Then
MsgBox "zaznacz rok lub nauczyciela aby wydrukować plan"
End If
End Sub
'r=1 k=7
'r=2 k=23
'r=3 k=39
'r=4 k=55
'drukowanie rozkładu dla nauczyciela
Sub DrukujRozkładN(nau, m1, m2 As Variant)
w = ActiveCell.Row
k = ActiveCell.Column
rok = Int(((k - 7) / 16)) + 1
Sheets("DRUK").Range("A1") = nau
w1 = 2
For w = 8 To 366 + 7
dat = Cells(w, 1)
mie = Month(dat)
'god = Cells(w, kol)
If (mie >= m1) And (mie <= m2) Then 'And (god > 0) Then
For k = 7 To 70
g = Cells(w, k)
n = Cells(2, k)
If (g > 0) And (n = nau) Then
'dni tygodnia
txtd = Format(dat, "yyyy-mm-dd") 'data
txtw = Format(dat, "ddd") 'dzień tyg
txt0 = txtd & " (" & txtw & ")"
'tutaj sprawdzamy datę
'ale mogłoby sprawdzić poprzednią datę
'jesli taka sama to do poprzedniej dokleić
dataAKT = txt0
dataPOP = Sheets("DRUK").Cells(w1 - 1, 2)
If dataPOP = dataAKT Then
w1 = w1 - 1
End If
Sheets("DRUK").Cells(w1, 2) = txt0
'godziny
If Weekday(dat) < 7 Then txtg = "15:00" 'czw
'If Weekday(dat) = 6 Then txtg = "15:00" 'pią
If Weekday(dat) = 7 Then txtg = "8:00" 'sob
Sheets("DRUK").Cells(w1, 3) = txtg 'Weekday(dat)
txt1 = ""
prz = Cells(1, k)
If k >= 7 Then r = 7
If k >= 23 Then r = 23
If k >= 39 Then r = 39
If k >= 55 Then r = 55
rok = Cells(1, r)
txt1 = rok & " [" & g & "] " & prz
Sheets("DRUK").Cells(w1, 1) = w1 - 1
txtx = Sheets("DRUK").Cells(w1, 4)
If txtx <> "" Then txtx = txtx & ", "
Sheets("DRUK").Cells(w1, 4) = txtx & txt1
w1 = w1 + 1
End If
Next k
End If
Next w
Sheets("DRUK").Select
End Sub
'drukowanie rozkłądu dla roku
Sub DrukujRozkładM(r, m1, m2 As Variant)
kol = 7 + (r - 1) * 16
rok = Cells(1, kol)
Sheets("DRUK").Range("A1") = rok
w1 = 2
For w = 8 To 366 + 7
dat = Cells(w, 1)
mie = Month(dat)
god = Cells(w, kol)
If (mie >= m1) And (mie <= m2) And (god > 0) Then
'dni tygodnia
txtd = Format(dat, "yyyy-mm-dd") 'data
txtw = Format(dat, "ddd") 'dzień tyg
txt0 = txtd & " (" & txtw & ")"
Sheets("DRUK").Cells(w1, 2) = txt0
'godziny
If Weekday(dat) < 7 Then txtg = "15:00" 'czw
'If Weekday(dat) = 6 Then txtg = "15:00" 'pią
If Weekday(dat) = 7 Then txtg = "8:00" 'sob
Sheets("DRUK").Cells(w1, 3) = txtg 'Weekday(dat)
'przedmioty
txt1 = ""
txtp = ", "
For k = kol + 1 To kol + 15
g = Cells(w, k)
If g > 0 Then
prz = Cells(1, k)
nau = Cells(2, k)
If txt1 = "" Then
txt1 = prz & " [" & g & "] " & nau
Else
txt1 = txt1 & ", " & prz & " [" & g & "] " & nau
End If
End If
Next k
Sheets("DRUK").Cells(w1, 1) = w1 - 1
Sheets("DRUK").Cells(w1, 4) = txt1
w1 = w1 + 1
End If
Next w
Sheets("DRUK").Select
End Sub
Sub skokPLAN()
Sheets("razem").Select
End Sub
Sub DzieńNie()
DzieńOnOff 1
End Sub
Sub DzieńPon()
DzieńOnOff 2
End Sub
Sub DzieńWto()
DzieńOnOff 3
End Sub
Sub DzieńŚro()
DzieńOnOff 4
End Sub
Sub DzieńCzw()
DzieńOnOff 5
End Sub
Sub DzieńPią()
DzieńOnOff 6
End Sub
Sub DzieńSob()
DzieńOnOff 7
End Sub
Sub DzieńOnOff(jaki)
For w = 8 To 311
dt = CInt(Cells(w, 4))
If dt = jaki Then
If Rows(w).RowHeight = 0 Then
Rows(w).RowHeight = 15.75
Else
Rows(w).RowHeight = 0
End If
End If
Next w
End Sub
Sub próba()
'DzieńOnOff 1
w = ActiveCell.Row
k = ActiveCell.Column
x = CInt(Cells(w, k))
MsgBox x
End Sub
Sub PodkreślenieNiedzieli()
wi = ActiveCell.Row
ko = ActiveCell.Column
For w = 8 To 311
dt = CInt(Cells(w, 4))
If dt = 1 Then
Rows(w).Select
'Selection.Borders(xlDiagonalDown).LineStyle = xlNone
'Selection.Borders(xlDiagonalUp).LineStyle = xlNone
'Selection.Borders(xlEdgeLeft).LineStyle = xlNone
'Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
'Selection.Borders(xlEdgeRight).LineStyle = xlNone
'Selection.Borders(xlInsideVertical).LineStyle = xlNone
'Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End If
Next w
Cells(wi, ko).Select
End Sub
'wystarczy wybrać komórkę i pokazuje do której skok
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
w = Target.Row
k = Target.Column
'MsgBox w & " " & k
End Sub
'pokazuje komórkę w której coś zmieniliśmy
Private Sub Worksheet_Change(ByVal Target As Range)
'Target.Interior.Color = RGB(255, 0, 0)
w = Target.Row
k = Target.Column
'MsgBox w & " " & k
End Sub