Program komputerowy ZASTĘPSTWA powstał na przełomie 2010 i 2011 roku, w chwili gdy w szkole wprowadzany był dziennik elektroniczny. Moduł zastępstwa w e-dzienniku nie spełniał naszych wymagań i dlatego powstała koncepcja napisania programu, który będzie dopasowany do szkolnej specyfiki (m.in. duża liczba łączonych grup, dzielonych klas, spersonalizowane wydruki, współpraca ze szkolnym telebimem, itp.).
mgr inż. Wacław Libront
Program komputerowy ZASTĘPSTWA w podstawowej swojej wersji umożliwia:
- wpisywania zastępstw za pomocą przycisków i gotowych schematów
- drukowania różnorodnych zestawień
- wstawianie informacji o zastępstwach na szkolny telebim (informacja o telebimie w osobnym artykule).
Kolejne wersje programu były wzbogacane o drobne elementy i poprawki, a roku 2016 pojawił się nowy duży moduł, którego zadaniem było pobranie informacji z e-dziennika o różnorodnych niepoprawnych wpisach i konfrontacja ich z wpisami do zastępstw.
W obecnej chwili program ZASTĘPSTWA składa się z 6 arkuszy i ponad 1500 wierszy kodu źródłowego. Wszystkie funkcje obsługiwane są przyciskami za pomocą myszki i praktycznie wyeliminowana jest potrzeba ręcznego wpisywania danych.
Z programistycznego punktu widzenia obsługowa część (tworzenie i drukowanie zastępstw) nie nastręczała większych problemów. Od programu wymagane było by sprawnie i bez błędów reagował na różne nietypowe sytuacje (nie zawieszał się). Natomiast część programu związana z wyszukiwaniem brakujących wpisów w e-dzienniku stanowiła nie lada wyzwanie. Po pierwsze e-dziennik nie produkuje zestawienia brakujących godzin w formie bazodanowej lecz tylko w formacie PDF, z którym należało sobie w jakiś sposób poradzić. Po drugie zaimportowane w ten sposób dane (zapisy e-dziennika) należało skonfrontować i porównać z zapisami w module ZASTĘPSTW.
Dla wszystkich zainteresowanych kolejna porcja kodu źródłowego
Sub auto_open()
Sheets("KSIĘGA").Select
Sheets("KSIĘGA").Range("B4") = Date
kolor = Range("B4").Interior.ColorIndex
If kolor = 35 Then kolor = 36 Else kolor = 35
Range("B4").Interior.ColorIndex = kolor
Application.CellDragAndDrop = False 'bez przeciągania komórek
w = 5
Do
w = w + 1
Loop Until Sheets("KSIĘGA").Cells(w, 2) = ""
Sheets("KSIĘGA").Cells(w, 2).Select
End Sub
Sub auto_close()
Application.CellDragAndDrop = True
End Sub
'przyciski ustwiania kolorów do wypełniania wierszy
Sub KolorŻółty()
Range("B4").Interior.ColorIndex = 36
End Sub
Sub KolorZielony()
Range("B4").Interior.ColorIndex = 35
End Sub
'przyciski zmiany daty o 1
Sub DataMniej()
d = Sheets("KSIĘGA").Range("B4")
d = d - 1
Sheets("KSIĘGA").Range("B4") = d
End Sub
Sub DataWięcej()
d = Sheets("KSIĘGA").Range("B4")
d = d + 1
Sheets("KSIĘGA").Range("B4") = d
End Sub
'kol kolumna do której wstawiamy
'kon kolumna z której pobieramy na arkuszu PAR
Sub Wstaw(kol, kon As Variant)
w = Selection.Row
k = Selection.Column
If w > 4 Then
nr = Cells(2, kol)
nap = Sheets("PAR").Cells(1 + nr, kon) 'wstawiamy skrót
If CzyWstawiać(w, kol) = True Then Cells(w, kol) = nap
End If
Cells(2, kol) = 0
End Sub
'sortowanie według daty klasy i grupy
Sub SortujDKG()
Range("A4:M10000").Sort _
Key1:=Range("B5"), Order1:=xlAscending, _
Key2:=Range("C5"), Order2:=xlAscending, _
Key3:=Range("D5"), Order3:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, _
DataOption3:=xlSortNormal
End Sub
'sortowanie według daty klasy i grupy
Sub SortujNUM()
Range("A4:M10000").Sort _
Key1:=Range("A5"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal
End Sub
Sub WstawKlasę()
Wstaw 3, 5
End Sub
Sub WstawKlasę1()
Wstaw 4, 5
End Sub
Sub WstawGrupę()
Wstaw 5, 7
End Sub
Sub WstawLekcję()
Wstaw 6, 1
End Sub
Sub WstawNieobecny()
Wstaw 7, 3
End Sub
Sub WstawZastępca()
Wstaw 8, 3
End Sub
Sub WstawPrzedmiot()
Wstaw 9, 9
End Sub
'w opisach wstawianie odmiennie bo ustawiamy kursor
Sub WstawOpis()
'Wstaw 10, 10
kol = 10
kon = 10
w = Selection.Row
k = Selection.Column
If w > 4 Then
nr = Cells(2, kol)
nap = Sheets("PAR").Cells(1 + nr, kon) 'wstawiamy skrót
If CzyWstawiać(w, kol) = True Then
Cells(w, kol) = nap
Cells(w, 10).Select
SendKeys "{F2}"
End If
End If
Cells(2, kol) = 0
End Sub
Sub WstawRodzaj()
Wstaw 11, 13
End Sub
Sub WstawPrzyczyna()
Wstaw 12, 17
End Sub
Sub WstawCzas()
Wstaw 13, 18
End Sub
Sub WstawDatę()
kol = 2 'kolumna do której wstawiamy
w = Selection.Row
k = Selection.Column
If w > 4 Then
d = Sheets("KSIĘGA").Range("B4")
nap = d
If CzyWstawiać(w, kol) = True Then
Cells(w, kol) = nap
End If
End If
End Sub
'jeżeli komórka zajęta to pytanie
Function CzyWstawiać(w, k As Variant) As Boolean
CzyWstawiać = True
If Cells(w, k) <> "" Then
Dim Msg, Style, Title
Msg = "KOMÓRKA ZAJĘTA" & Chr(13) & Chr(13) & _
"Czy na pewno zastąpić?"
Style = vbYesNo + vbCritical + vbDefaultButton1
Title = "ZAMIANA"
wynik = MsgBox(Msg, Style, Title)
If wynik = vbNo Then
CzyWstawiać = False
End If
End If
End Function
'wciskamy przycisk, szukamy pierwszego wolnego
Sub NastępnyWpis()
w = 4
Do
w = w + 1
Loop Until Cells(w, 1) = ""
Cells(w, 1) = Cells(2, 1) + 1
Cells(w, 1).Select
WstawDatę
kolor = Range("B4").Interior.ColorIndex
'Rows(w).Interior.ColorIndex = kolor
Range(Cells(w, 1), Cells(w, 13)).Interior.ColorIndex = kolor
End Sub
Sub Zapisz()
ActiveWorkbook.Save
End Sub
Sub koniec()
Dim Msg, Style, Title
Msg = "Czy na pewno chcesz skończyć?"
Style = vbYesNo + vbCritical + vbDefaultButton2
Title = "KONIEC"
wynik = MsgBox(Msg, Style, Title)
If wynik = vbYes Then
Application.Quit
End If
End Sub
Sub NagłówkiONOFF()
If ActiveWindow.DisplayHeadings = False Then ActiveWindow.DisplayHeadings = True Else ActiveWindow.DisplayHeadings = False
End Sub
Sub AutoFiltrONOFF()
Range("B6").Select
Selection.AutoFilter
End Sub
Sub SkokKsiążka()
Sheets("KSIĘGA").Select
End Sub
Sub SkokPar()
Sheets("PAR").Select
End Sub
Sub SkokKarta()
Sheets("KARTA").Select
End Sub
Sub SkokZastępstwa()
Sheets("ROZL").Select
End Sub
'kolejna strona w księdze
Sub NastępnaStrona()
'bierzemy numer z tego drugiego, bo mogło być dwie strony
s = Sheets("KARTA").Range("G2")
s = s + 1
Sheets("KARTA").Range("G2") = s
'Sheets("KARTA").Range("E2") = Sheets("KARTA").Range("G2")
End Sub
Sub PoprzedniaStrona()
'bierzemy numer z tego drugiego, bo mogło być dwie strony
s = Sheets("KARTA").Range("G2")
s = s - 1
Sheets("KARTA").Range("G2") = s
'Sheets("KARTA").Range("E2") = Sheets("KARTA").Range("G2")
End Sub
Sub NicNieRób()
End Sub
Sub PokażWszystko()
On Error GoTo błąd
ActiveSheet.ShowAllData
Application.ScreenUpdating = False
w = 5
Do
w = w + 1
Loop Until Sheets("KSIĘGA").Cells(w, 1) = ""
Application.ScreenUpdating = True
Sheets("KSIĘGA").Cells(w, 1).Select
błąd:
Exit Sub
End Sub
'ostatni komunikat
Dim kom As Variant
Dim ŁĄ As Variant 'gdy kilka wierszy zaznaczone
Dim dataPOP As Variant
'a może zaznaczyć dowolną datę i z tej wydruk
Sub TwórzZAST()
On Error GoTo błąd
Dim ocell As Range
'Application.ScreenUpdating = False
arkusz = ActiveSheet.Name
w = Selection.Row
k = Selection.Column
data = Sheets("KSIĘGA").Cells(w, 2)
dataPOP = data 'zapamiętujemy na wszelki wypadek
dzi = Weekday(data)
Select Case dzi
Case 1
dzie = "niedziela"
Case 2
dzie = "poniedziałek"
Case 3
dzie = "wtorek"
Case 4
dzie = "środa"
Case 5
dzie = "czwartek"
Case 6
dzie = "piątek"
Case 7
dzie = "sobota"
End Select
If data = "" Then
MsgBox "NIE WYBRANO WIERSZA Z DANYMI"
Exit Sub
End If
'sprawdzamy czy wybrano kilka wierszy - tylko te wrzucamy do zestawień
'ale tylko te z jednej, pierwszej daty
ŁĄ = 0
For Each ocell In Selection
ŁĄ = ŁĄ + 1
Next
If ŁĄ > 1 Then
Dim Msg, Style, Title
Msg = "WYBRANO KILKA WIERSZY" & Chr(13) & Chr(13) & _
"Czy tworzyć zestawienia TYLKO DLA TYCH WIERSZY?" & Chr(13) & _
"(wybrane wiersze muszą mieć tą samą datę!)"
Style = vbYesNo + vbCritical + vbDefaultButton1
Title = "TWÓRZ"
wynik = MsgBox(Msg, Style, Title)
If wynik = vbYes Then 'zestawienia tylko dla nich
'zapamiętać wiersze zaznaczone
'For Each ocell In Selection
' wiersz = ocell.Row
' 'Sheets("KSIĘGA").Cells(wiersz, 2) = 1 'wpisujemy na razie pierwszy dzień
' Sheets("OBSŁUGA").Cells(wiersz, 20) = Sheets("KSIĘGA").Cells(wiersz, 2)
'Next
'wpisz wszystkim wierszom z tej daty 1
wi = 4
Do
dat = Sheets("KSIĘGA").Cells(wi, 2)
If dat = data Then Sheets("KSIĘGA").Cells(wi, 2) = #1/1/1900#
wi = wi + 1
Loop Until Sheets("KSIĘGA").Cells(wi, 2) = ""
'a teraz wybranym wierszom wpisać datę poprawną
For Each ocell In Selection
wiersz = ocell.Row
Sheets("KSIĘGA").Cells(wiersz, 2) = data
' Sheets("OBSŁUGA").Cells(wiersz, 20) = Sheets("KSIĘGA").Cells(wiersz, 2)
Next
Else
Cells(w, k).Select
Exit Sub
End If
End If
Cells(w, k).Select
'przefiltrować albo wyszukać wszystkie - sort i kolejne
'sortuj i wyszukaj kolejne
SortujDKG
wi = 4
ko = 2
Do
wi = wi + 1
If wi > 10000 Then
MsgBox "chyba nie ma takiej daty"
Exit Sub
End If
Loop Until Cells(wi, 2) = data
n1 = " " & "ZASTĘPSTWA " & data & " (" & dzie & ")"
n01 = "ZASTĘPSTWA " & data & " (" & dzie & ")"
Sheets("KARTA").Columns("B:B").ClearContents
Sheets("KARTA").Range("C150:C350").ClearContents
Sheets("KARTA").Columns("D:E").ClearContents
Sheets("KARTA").Range("D3") = data & " (" & dzie & ")"
'wszystkie pola trzeba schować a potem będziemy je odkrywać pojedynczo
Sheets("KARTA").Rows("5:350").RowHeight = 0
Sheets("KARTA").Rows(20).RowHeight = 18
Sheets("KARTA").Rows(100).RowHeight = 18
Sheets("KARTA").Rows(150).RowHeight = 18
'teraz nauczycieli wyszukujemy za pomocą obsługi i unikatowych
Sheets("OBSŁUGA").Columns("A:C").ClearContents 'nauczyciele nieobecni
Sheets("OBSŁUGA").Columns("F:G").ClearContents 'nauczyciele zastępujący
Sheets("OBSŁUGA").Columns("I:N").ClearContents 'klasy ze zmianami
'przepisać wpisy z księgi do obsługi
wj = wi
wo = 1
Do
Sheets("OBSŁUGA").Cells(wo, 1) = Cells(wj, 7) 'skrót nauczyciela
Sheets("OBSŁUGA").Cells(wo, 2) = Cells(wj, 12) 'skrót zwolnienia
Sheets("OBSŁUGA").Cells(wo, 6) = Cells(wj, 8) 'skrót nauczyciela zastępcy
Sheets("OBSŁUGA").Cells(wo, 9) = Cells(wj, 3) 'skrót klasy
Sheets("OBSŁUGA").Cells(wo, 17) = Cells(wj, 13) 'od godziny nieobecność
'klasę łączoną wklejamy 50 komórek dalej, a potem i tak WybierzPojednym dobrze bo do 100 sprawdza
Sheets("OBSŁUGA").Cells(wo + 50, 9) = Cells(wj, 4) 'skrót klasy 1
'gdy puste OPIS i RODZAJ to daj sygnał, że trzeba coś wpisać
If Cells(wj, 10) = "" And Cells(wj, 11) = "" Then
Cells(wj, 10).Select
Msg = "OPIS i RODZAJ są psute" & Chr(13) & Chr(13) & _
"Czy chcesz poprawić ten wpis?"
Style = vbYesNo + vbCritical + vbDefaultButton1
Title = "POPRAW"
wynik = MsgBox(Msg, Style, Title)
If wynik = vbYes Then
GoTo błąd
End If
End If
wj = wj + 1
wo = wo + 1
Cells(wj - 1, k).Select
Loop Until Cells(wj, 2) <> data
'wybieranie po jednym skrócie z listy na karcie OBSŁUGA
WybierzPoJednym 1, 3
WybierzPoJednym 6, 7
WybierzPoJednym 9, 10
'KlasyRozdziel 'klasy łączone dodatkowo rozdzielamy
'w obsłudze są nauczyciele pojedynczy w kolumnie B
n2 = " " & "nieobecni nauczyciele: "
n02 = "nieobecni nauczyciele: "
wo = 1
Do
nau = Sheets("OBSŁUGA").Cells(wo, 3)
nau = DajNazwę(nau, 3)
zwo = Sheets("OBSŁUGA").Cells(wo, 4)
zwo = DajNazwę(zwo, 17)
cza = Sheets("OBSŁUGA").Cells(wo, 8)
If cza = 0 Then cza = ""
If cza <> "" Then cza = " od godz. " & Format(cza, "h:m")
If zwo = "" Then wpis = nau Else wpis = nau & " (" & zwo & cza & ")"
wpis1 = nau & cza
Sheets("KARTA").Cells(wo + 4, 4) = wpis
Sheets("KARTA").Rows(wo + 4).RowHeight = 18
Sheets("KARTA").Rows(wo + 4).Rows.AutoFit
If wo > 5 Then MsgBox "nieobecni nauczyciele zostali zapisani, ale należy ich odsłonić"
n2 = n2 & wpis1 & ", "
n02 = n02 & wpis1 & ", "
wo = wo + 1
Loop Until Sheets("OBSŁUGA").Cells(wo, 3) = ""
'otwieramy plik do zapisu
plik = "c:\www\zast.txt"
'zapisanie z datą - archiwum, ale usunąć wszelkie formatowania
d = Format(Date, "yyyy-mm-dd")
kopia = "c:\www\zast " + d + ".txt"
Open plik For Output As #1
Print #1, n1
Print #1, n2
Print #1, ""
Open kopia For Output As #2
Print #2, n01
Print #2, n02
Print #2, ""
'gdy są komunikaty ale najlepiej na początku bo w ZAST.TXT musi być na początku
'w zmiennej kom jest ostatni komunikat i on też będzie przypisany do wpisów z przedmiotem KOM
wj = wi
wk = 19 'wiersze komunikatów
Do
ro = Cells(wj, 11)
If ro = "KOM" Then
kom = Cells(wj, 10)
Sheets("KARTA").Cells(wk, 2) = "KOMUNIKAT"
Sheets("KARTA").Cells(wk, 4) = LTrim(kom)
Sheets("KARTA").Rows(wk).RowHeight = 22.5
Sheets("KARTA").Rows(wk).Rows.AutoFit
wk = wk - 1
Print #1, " " & "KOMUNIKAT: " & LTrim(kom)
Print #1, ""
Print #2, "KOMUNIKAT: " & LTrim(kom)
Print #2, ""
End If
wj = wj + 1
Cells(wj - 1, k).Select
Loop Until Cells(wj, 2) <> data
'a teraz cała reszta
wj = wi
wo = 1
Do
'to są skróty
kl1 = Cells(wj, 3)
kl1n = DajNazwę(kl1, 5)
klł = kl1n 'klasa łączona
kl2 = Cells(wj, 4)
If kl2 <> "" Then
kl2n = DajNazwę(kl2, 5)
'klł = Mid(kl1, 1, 2) + "-" + Mid(kl2, 2, 1) + " " + Mid(kl1, 3, 10)
klł = kl1 + "-" + kl2
End If
gr = Cells(wj, 5)
grn = gr
'grn = DajNazwę(gr, 7)
go = Cells(wj, 6)
If go <> "" Then go = "lekcja " & go
na = Cells(wj, 8)
nan = DajNazwę(na, 3)
pr = Cells(wj, 9)
prn = DajNazwę(pr, 9)
op = Cells(wj, 10)
ro = Cells(wj, 11)
'wypisuj wszystkie prócz komunikatów
If ro <> "KOM" Then
ro = DajNazwę(ro, 13)
If ro <> "" Then ro = "" 'ro = " (" & ro & ")"
rz = Cells(wj, 12)
rz = DajNazwę(rz, 17)
If rz <> "" Then rz = " (" & rz & ")"
'********** WPISY DO KSIĘGI ************************************
If gr = "" Then wpis1 = klł Else wpis1 = klł & " [" & grn & "]"
n = " " & wpis1
n0 = wpis1
Sheets("KARTA").Cells(wo + 20, 2) = LTrim(wpis1)
wp = " " & nan & " " & prn & " "
wpis2 = go & " " & LTrim(wp) & op & ro
n1 = " " & wpis2
n01 = wpis2
Sheets("KARTA").Cells(wo + 20, 4) = LTrim(wpis2)
Sheets("KARTA").Rows(wo + 20).RowHeight = 22.5
Sheets("KARTA").Rows(wo + 20).Rows.AutoFit
Print #1, n & n1
Print #2, n0 & n01
End If
wo = wo + 1
wj = wj + 1
Cells(wj - 1, k).Select
Loop Until Cells(wj, 2) <> data
Print #1, ""
Print #1, " " & "KONIEC " & data
Close #1
Print #2, ""
Print #2, "KONIEC " & data
Close #2
'********** KLASY I NAUCZYCIELE PODPISY ***************************
wo = 1
Do
nau = Sheets("OBSŁUGA").Cells(wo, 7)
nau = DajNazwę(nau, 3)
Sheets("KARTA").Cells(wo + 100, 4) = nau
Sheets("KARTA").Rows(wo + 100).RowHeight = 18
wo = wo + 1
Loop Until Sheets("OBSŁUGA").Cells(wo, 7) = ""
wo = 1
Do
kla = Sheets("OBSŁUGA").Cells(wo, 10)
kla = DajNazwę(kla, 5)
Sheets("KARTA").Cells(wo + 100, 2) = kla
Sheets("KARTA").Rows(wo + 100).RowHeight = 18
wo = wo + 1
Loop Until Sheets("OBSŁUGA").Cells(wo, 10) = ""
'na wszelki wypadek bo coś zmieniało format
With Sheets("KARTA").Range("D151:D350").Font
.FontStyle = "Pogrubiony"
.Size = 14
End With
'********** PASKI DLA KLAS ****************************************
'a teraz paski dla klas od wiersza 151
wo = 1 'wiersz z obsługi
wx = 151 'wiersz do którego wpis klasy na karcie
Do
kla = Sheets("OBSŁUGA").Cells(wo, 10)
kla = DajNazwę(kla, 5)
Sheets("KARTA").Cells(wx, 2) = kla
'czy ta data coś robi - pod spodem następna
Sheets("KARTA").Cells(wx, 3) = data
Sheets("KARTA").Rows(wx).RowHeight = 40
Sheets("KARTA").Rows(wx).Rows.AutoFit
'i teraz trzeba przelecieć po wszystkich wpisach to co zgodne z wybraną klasą
'jeszcze posortowane według dat - wi pierwszy wiersz tej daty
wj = wi
Do
'wpis od razu n apoczątku i tylko raz nawet gdy nie trzeba
kl1 = Cells(wj, 3)
kl1n = DajNazwę(kl1, 5)
klł = kl1n 'klasa łączona
kl2 = Cells(wj, 4)
If kl2 <> "" Then
kl2n = DajNazwę(kl2, 5)
klł = Mid(kl1, 1, 2) + "-" + Mid(kl2, 2, 1) + " " + Mid(kl1, 3, 10)
End If
gr = Cells(wj, 5)
If gr = "" Then gr = "" Else gr = " [" & gr & "] "
'gr = DajNazwę(gr, 7)
go = Cells(wj, 6)
If go <> "" Then go = "lekcja " & go
na = Cells(wj, 8)
na = DajNazwę(na, 3)
pr = Cells(wj, 9)
prn = DajNazwę(pr, 9)
If pr = "KOM" Then
op = kom
Else
op = Cells(wj, 10)
End If
'If pr = "" Then pr = "" Else pr = " [" & pr & "] "
wp = go & " " & na & " " & prn & " " '& pr
dlwp = Len(gr & LTrim(wp))
wpis = gr & LTrim(wp) & op
Sheets("KARTA").Cells(wx, 2) = kla
'dzień tygodnia
Sheets("KARTA").Range("H1") = Weekday(data)
Sheets("KARTA").Cells(wx, 3) = data & " " & Chr(10) & Sheets("KARTA").Range("I1")
If kla = kl1n Then 'gdy napisy z obsługi=napi z księgi to wstawiamy
Sheets("KARTA").Cells(wx, 4) = LTrim(wpis)
Sheets("KARTA").Rows(wx).RowHeight = 40
Sheets("KARTA").Rows(wx).Rows.AutoFit
With Sheets("KARTA").Cells(wx, 4).Characters(START:=dlwp, Length:=500).Font
.FontStyle = "Kursywa"
.Size = 13
End With
wx = wx + 1
End If '
'jest łączone
If kl2 <> "" Then 'pojedyncza klasa
If kla = kl2n Then
Sheets("KARTA").Cells(wx, 4) = LTrim(wpis)
Sheets("KARTA").Rows(wx).RowHeight = 40
Sheets("KARTA").Rows(wx).Rows.AutoFit
With Sheets("KARTA").Cells(wx, 4).Characters(START:=dlwp, Length:=500).Font
.FontStyle = "Kursywa"
.Size = 13
End With
wx = wx + 1
End If
End If
wj = wj + 1 'wiersz w księdze
Cells(wj - 1, k).Select
Loop Until Cells(wj, 2) <> data
wo = wo + 1
wx = wx + 1
Loop Until Sheets("OBSŁUGA").Cells(wo, 10) = ""
'********** KONIEC - PASKI DLA KLAS ****************************************
'********** PASKI DLA NAUCZYCIELI ****************************************
'a teraz paski dla klas od wiersza 151
wo = 1 'wiersz z obsługi
wx = 251 'wiersz do którego wpis klasy na karcie
Do
nau = Sheets("OBSŁUGA").Cells(wo, 7) 'skrót
nau = DajNazwę(nau, 3) 'pełna nazwa
If nau <> "" Then
Sheets("KARTA").Cells(wx, 2) = nau
'dzień tygodnia
Sheets("KARTA").Range("H1") = Weekday(data)
Sheets("KARTA").Cells(wx, 3) = data & " " & Chr(10) & Sheets("KARTA").Range("I1")
Sheets("KARTA").Rows(wx).RowHeight = 40
Sheets("KARTA").Rows(wx).Rows.AutoFit
End If
'i teraz trzeba przelecieć po wszystkich wpisach to co zgodne z wybranym nauczycielem
wj = wi 'pierwszy wiersz zgodny z datą w księdze - reszta ładnie posortowana
Do
'wpis od razu n apoczątku i tylko raz nawet gdy nie trzeba
kl1 = Cells(wj, 3)
kl1n = DajNazwę(kl1, 5)
klł = kl1n 'klasa łączona
kl2 = Cells(wj, 4)
If kl2 <> "" Then
kl2n = DajNazwę(kl2, 5)
klł = Mid(kl1, 1, 2) + "-" + Mid(kl2, 2, 1) + " " + Mid(kl1, 3, 10)
End If
gr = Cells(wj, 5)
If gr = "" Then gr = " " Else gr = " [" & gr & "] "
'gr = DajNazwę(gr, 7)
go = Cells(wj, 6)
If go <> "" Then go = "lekcja " & go
na = Cells(wj, 8)
na = DajNazwę(na, 3)
pr = Cells(wj, 9)
prn = DajNazwę(pr, 9)
If pr = "KOM" Then
op = kom
Else
op = Cells(wj, 10)
End If
'If pr = "" Then pr = "" Else pr = " [" & pr & "] "
'wp = go & " " & na & " " & prn & " " '& pr
'If pr = "" Then pr = "" Else pr = " [" & pr & "] "
'op = Cells(wj, 10)
ro = Cells(wj, 11)
ro = DajNazwę(ro, 13)
If ro <> "" Then ro = " (" & ro & ")"
wp = go & " " & prn & " " '& pr
dlwp = Len(klł & gr & LTrim(wp))
wpis = klł & gr & LTrim(wp) & op & ro
If (na <> "") And (nau = na) Then
Sheets("KARTA").Cells(wx, 4) = wpis
Sheets("KARTA").Rows(wx).RowHeight = 40
Sheets("KARTA").Rows(wx).Rows.AutoFit
With Sheets("KARTA").Cells(wx, 4).Characters(START:=dlwp, Length:=500).Font
.FontStyle = "Kursywa"
.Size = 13
End With
wx = wx + 1
End If
wj = wj + 1 'wiersz w księdze
Cells(wj - 1, k).Select
Loop Until Cells(wj, 2) <> data
wo = wo + 1
wx = wx + 1
Loop Until Sheets("OBSŁUGA").Cells(wo, 7) = ""
'********** KONIEC - PASKI DLA NAUCZYCIELI ****************************************
SortujNUM
If ŁĄ > 1 Then
wi = 4
Do
dat = Sheets("KSIĘGA").Cells(wi, 2)
If dat = #1/1/1900# Then Sheets("KSIĘGA").Cells(wi, 2) = data
wi = wi + 1
Loop Until Sheets("KSIĘGA").Cells(wi, 2) = ""
End If
Application.ScreenUpdating = True
SkokKarta
Range("B20").Select
Exit Sub
błąd:
SortujNUM
If ŁĄ > 1 Then
wi = 4
Do
dat = Sheets("KSIĘGA").Cells(wi, 2)
If dat = #1/1/1900# Then Sheets("KSIĘGA").Cells(wi, 2) = data
wi = wi + 1
Loop Until Sheets("KSIĘGA").Cells(wi, 2) = ""
End If
Application.ScreenUpdating = True
'gdy prawdziwy błąd to komunikat
'gdy poprawiamy wpis bo brak OPISU i RODZAJU to bez komunikatu
If Title <> "POPRAW" Then MsgBox "błąd w procedurze TwórzZAST"
End Sub
'kolumna - w niej skrót a otrzymujemy z jednej w lewo - nazwa właściwa
Function DajNazwę(skrót, kolumna As Variant) As Variant
Sheets("OBSŁUGA").Range("E1") = skrót
Sheets("OBSŁUGA").Range("E2") = kolumna
w = Sheets("OBSŁUGA").Range("E6")
DajNazwę = CStr(Sheets("PAR").Cells(w, kolumna - 1))
End Function
'w arkuszu OBSŁUGA są już wpisane skróty do kolumny SKĄD
'i teraz w kolumnie DOKĄD wypisujemy po jednym
'skąd - kolumna 1,2...
'dokąd - kolumna 1,2..
Sub WybierzPoJednym(skąd, dokąd As Variant)
k = skąd
w = 1
k1 = dokąd
w1 = 1
Do
nap = Sheets("OBSŁUGA").Cells(w, k)
nap1 = Sheets("OBSŁUGA").Cells(w1, k1)
If nap1 = "" Then 'gdy pusta komórka
Sheets("OBSŁUGA").Cells(w1, k1) = nap
w = w + 1
w1 = 1
Else
If nap1 = nap Then 'gdy już jest element
w = w + 1
w1 = 1
Else 'gdy element różny
w1 = w1 + 1
End If
End If
Loop Until w > 1000
End Sub
Sub DrukujKarta()
On Error GoTo błąd
strona = Sheets("KARTA").Range("G2")
nr = 1
wiersz = ActiveSheet.HPageBreaks(nr).Location.Row
powrót:
If wiersz > 100 Then 'tylko jedna strona wpisów, na drugiej podpisy
'pierwsza kartka
zakres = "$B$2:$E$99"
Sheets("KARTA").Range("E2") = "s." & strona
ActiveSheet.PageSetup.PrintArea = zakres
ActiveWindow.SelectedSheets.PrintPreview
strona = strona + 1
End If
If wiersz < 100 Then 'wpisów więcej niż na jednej stronie a na trzeciej podpisy
'pierwsza kartka
zakres = "$B$2:$E$" & wiersz - 1
Sheets("KARTA").Range("E2") = "s." & strona
ActiveSheet.PageSetup.PrintArea = zakres
ActiveWindow.SelectedSheets.PrintPreview
strona = strona + 1
'i trzeba by pomyśleć co by było gdyby było jeszcze więcej wpisów
'ale jak zaczniemy badać to będzie błąd
'można by wcześniej przebadać i do tablicy
'nr = nr + 1
'wiersz = ActiveSheet.HPageBreaks(nr).Location.Row
'druga kartka
zakres = "$B$" & wiersz & ":$E$99"
Sheets("KARTA").Range("E" & wiersz) = "s." & strona
ActiveSheet.PageSetup.PrintArea = zakres
ActiveWindow.SelectedSheets.PrintPreview
strona = strona + 1
End If
'ostatnia kartka - PODPISY
CzyDrukować = Sheets("KARTA").Range("I2")
If CzyDrukować = True Then
zakres = "$B$100:$E$149"
Sheets("KARTA").Range("E100") = "s." & strona
ActiveSheet.PageSetup.PrintArea = zakres
ActiveWindow.SelectedSheets.PrintPreview
strona = strona + 1
End If
Sheets("KARTA").Range("G2") = strona
ActiveSheet.PageSetup.PrintArea = ""
Exit Sub
błąd:
If wiersz = "" Then wiersz = 101
GoTo powrót
ActiveSheet.PageSetup.PrintArea = ""
End Sub
Sub DrukujPaski()
zakres = "$B$151:$D$350"
CzyDrukować = Sheets("KARTA").Range("J2")
If CzyDrukować = False Then zakres = "$B$251:$D$350"
ActiveSheet.PageSetup.PrintArea = zakres
ActiveWindow.SelectedSheets.PrintPreview
ActiveSheet.PageSetup.PrintArea = ""
End Sub
'jest już wpisane coś a my tylko kopiujemy
Sub SkopiujWpis()
On Error GoTo błąd
w = Selection.Row
k = Selection.Column
data = Sheets("KSIĘGA").Cells(w, 2)
If data = "" Then
MsgBox "NIE WYBRANO WIERSZA Z DANYMI"
Exit Sub
End If
'kolor
kol = Cells(w, k).Interior.ColorIndex
'szukaj pierwszego wolnego - sprawdzamy daty
wi = 4
Do
wi = wi + 1
Loop Until Cells(wi, 2) = ""
'a teraz kopiujemy
For ko = 1 To 13
Cells(wi, ko) = Cells(w, ko)
Cells(wi, ko).Interior.ColorIndex = kol
Next ko
Cells(wi, 1) = Cells(2, 1) + 1 'kolejny numer
Exit Sub
błąd:
MsgBox "błąd w procedurze SkopiujWpis"
End Sub
Sub UsuńWpis()
w = Selection.Row
k = Selection.Column
data = Sheets("KSIĘGA").Cells(w, 2)
If data = "" Then
MsgBox "NIE WYBRANO WIERSZA Z DANYMI"
Exit Sub
End If
Dim Msg, Style, Title
Msg = "USUWANIE WPISU" & Chr(13) & Chr(13) & _
"Czy na pewno usunąć cały wiersz?"
Style = vbYesNo + vbCritical + vbDefaultButton2
Title = "USUŃ"
wynik = MsgBox(Msg, Style, Title)
If wynik = vbYes Then
Rows(w).Select
Selection.Delete Shift:=xlUp
End If
Cells(w, k).Select
End Sub
Sub WstawWiersz()
w = Selection.Row
k = Selection.Column
Dim Msg, Style, Title
Msg = "WSTAWIANIE PUSTEGO WIERSZA" & Chr(13) & Chr(13) & _
"Czy na pewno wstawić pusty wiersz POD WYBRANYM?" & Chr(13) & Chr(13) & _
"(wszystkie wiersze poniżej zostaną przenumerowane)"
Style = vbYesNo + vbCritical + vbDefaultButton2
Title = "WSTAW"
wynik = MsgBox(Msg, Style, Title)
If wynik = vbYes Then
Rows(w + 1).Select
Selection.EntireRow.Insert
Cells(w + 1, 1) = Cells(w, 1) + 1
Cells(w + 1, 2) = Cells(w, 2)
Msg = "Czy przenumerować następne wiersze (+1)?"
Title = "NUMERUJ"
wynik = MsgBox(Msg, Style, Title)
If wynik = vbYes Then
w = w + 2
Do
Cells(w, 1) = Cells(w, 1) + 1
w = w + 1
Loop Until Cells(w, 1) = ""
End If
End If
End Sub
'wyliczamy daty i skaczemy do arkusza ROZL
Sub RozliczenieZastępstwPRZED()
'wyliczyć po jednej dacie
Application.ScreenUpdating = False
wj = 5
Do
Sheets("OBSŁUGA").Cells(wj, 11) = Cells(wj, 2) 'data
wj = wj + 1
Loop Until Cells(wj, 2) = ""
WybierzPoJednym 11, 12
'daty po jednej w kolumnie 12
'ile jest tych dat
wj = 1
Do
wj = wj + 1
Loop Until Cells(wj, 12) = ""
'Sheets("ROZL").Range("H3") = Date - 30 'Sheets("OBSŁUGA").Cells(1, 12)
Sheets("ROZL").Range("H4") = Date 'Sheets("OBSŁUGA").Cells(wj, 12)
r = Year(Date)
m = Month(Date)
d = 1
Sheets("ROZL").Range("H3").FormulaR1C1 = "=DATE(" & r & "," & m & ",1)"
Sheets("ROZL").Range("H6") = Date
'można by jeszcze od razu ustawić początek ikoniec miesiąca
SkokZastępstwa
Range("H3").Select 'ustawiamy się w ROZL na pierwszej dacie
End Sub
Sub RozliczenieZastępstwJEDEN()
n = Sheets("OBSŁUGA").Range("E13")
nau = Sheets("PAR").Cells(1 + n, 3)
Sheets("OBSŁUGA").Range("A1") = nau
Sheets("OBSŁUGA").Range("C1") = nau
RozliczenieZastępstwPO
'usunąć zapis w obsłudze
Sheets("OBSŁUGA").Columns("A:C").ClearContents
Sheets("OBSŁUGA").Range("E13") = ""
SkokZastępstwa
End Sub
Sub RozliczenieZastępstwPO()
Application.ScreenUpdating = False
kob = "Stwierdzam pod odpowiedzialnością służbową, że powyższe godziny odbyłam i dokonałam zapisu w dzienniku lekcyjnym."
fac = "Stwierdzam pod odpowiedzialnością służbową, że powyższe godziny odbyłem i dokonałem zapisu w dzienniku lekcyjnym."
dataOD = Sheets("ROZL").Range("H3")
dataDO = Sheets("ROZL").Range("H4")
Sheets("ROZL").Range("B6") = "Rozliczenie zastępstw (" & dataOD & " - " & dataDO & ")"
'autmat czy pytać za każdym razem
'czy podgląd wydruku
CzyPodgląd = Sheets("OBSŁUGA").Range("E12")
'przelatujemy od daty do daty i nauczycieli potem po jednym
'a jeśli drukujemy tylko jednego wybranego to od razu do rozliczania
'jak - tu siedzi numer wybranego nauczyciela z listy
jak = Sheets("OBSŁUGA").Range("E13")
If jak = "" Then
Sheets("OBSŁUGA").Columns("A:C").ClearContents
wk = 5
wo = 1
Do
data = Sheets("KSIĘGA").Cells(wk, 2)
nr = Sheets("KSIĘGA").Cells(wk, 1)
If (data >= dataOD) And (data <= dataDO) Then
nau = Sheets("KSIĘGA").Cells(wk, 8)
If nau <> "" Then
Sheets("OBSŁUGA").Cells(wo, 1) = nau
'Sheets("OBSŁUGA").Cells(wo, 2) = nr
wo = wo + 1
End If
End If
wk = wk + 1
Loop Until Sheets("KSIĘGA").Cells(wk, 2) = ""
WybierzPoJednym 1, 3
'już mamy po jednym nauczycielu
End If 'gdy nie ma pojedynczego
Application.ScreenUpdating = True
Sheets("ROZL").Range("F3") = "Bobowa, dnia: " & CDate(Sheets("ROZL").Range("H6"))
'wybieramy nauczycieli i odszukujemy w księdze znów od daty do daty
'po wszystkich na razie - chyba że wolno będzie to trzeba będzie od daty do daty po przesortowaniu
wo = 1 'wiersz w obsłudze - tu nauczyciele
Do 'obsługa
Sheets("ROZL").Range("C8:F37").ClearContents
Sheets("ROZL").Rows("8:37").RowHeight = 16.5
sNAU = Sheets("OBSŁUGA").Cells(wo, 3) 'pobieramy nauczyciela z obsługi
sNAUCZ = DajNazwę(sNAU, 3)
Sheets("ROZL").Range("B3") = sNAUCZ
wr = 8 'wiersz w rozliczeniach
wk = 5 'wiersz w księdze
zpt = 0 'ilość zajęć praktycznych
zt = 0 'iość zajęć teoretycznych
izas = 0 'ilość zastępstw
Do
data = Sheets("KSIĘGA").Cells(wk, 2)
If (data >= dataOD) And (data <= dataDO) Then
nau = Sheets("KSIĘGA").Cells(wk, 8) 'pobieramy nauczyciela z księgi
If nau = sNAU Then 'znalazło nauczyciela z przedziału dat
If Sheets("KSIĘGA").Cells(wk, 11) = "ZAS" Then 'ale jeszcze musi być zastępstwo
izas = izas + 1
Sheets("ROZL").Cells(wr, 3) = data
kla1 = Sheets("KSIĘGA").Cells(wk, 3)
kla2 = Sheets("KSIĘGA").Cells(wk, 4)
If kla2 <> "" Then
kla = kla1 & "-" & kla2
Else
kla = kla1
End If
Sheets("ROZL").Cells(wr, 4) = kla
Sheets("ROZL").Cells(wr, 5) = 1
prz = Sheets("KSIĘGA").Cells(wk, 9)
gru = Sheets("KSIĘGA").Cells(wk, 5)
god = Sheets("KSIĘGA").Cells(wk, 6)
'a teraz można by sprawdzać czy zapis godzinowy typu 3,4,5,6 i wstawić 4 godziny
'obsługa przecinków w OBSŁUGA U2
Sheets("OBSŁUGA").Range("U2") = god
'są godziny łącznie po przecinku
'If Sheets("OBSŁUGA").Range("V2") > 0 Then
' Sheets("ROZL").Cells(wr, 5) = Sheets("OBSŁUGA").Range("U1")
'End If
If prz = "ZP" Then
zpt = zpt + Sheets("OBSŁUGA").Range("U1")
Sheets("ROZL").Cells(wr, 5) = Sheets("OBSŁUGA").Range("U1")
Else
zt = zt + Sheets("OBSŁUGA").Range("U1")
Sheets("ROZL").Cells(wr, 5) = Sheets("OBSŁUGA").Range("U1")
End If
nap = prz & " [" & gru & "] " & god
Sheets("ROZL").Cells(wr, 6) = nap
wr = wr + 1
End If
End If
End If
wk = wk + 1
Loop Until Sheets("KSIĘGA").Cells(wk, 2) = ""
'Sheets("ROZL").Range("E40") = wr - 8
Sheets("ROZL").Range("E39") = zpt
Sheets("ROZL").Range("E38") = zt
If Right(sNAUCZ, 1) = "a" Then nap = kob Else nap = fac
Sheets("ROZL").Range("B52") = nap
If izas > 0 Then 'druk tylko gdy były zastępstwa
'ale jezcze ustawić wiersze
Application.ScreenUpdating = False
For i = wr To 37
Sheets("ROZL").Rows(i).RowHeight = 0
Next
Application.ScreenUpdating = True
If CzyPodgląd = True Then
ActiveWindow.SelectedSheets.PrintPreview
Else
ActiveWindow.SelectedSheets.PrintOut Copies:=1
End If
End If
wo = wo + 1
Loop Until Sheets("OBSŁUGA").Cells(wo, 3) = ""
'MsgBox "KONIEC DRUKOWANIA"
Sheets("OBSŁUGA").Columns("A:C").ClearContents
SkokKsiążka
End Sub
Sub DataROZLNas()
w = Selection.Row
k = Selection.Column
If (k = 8) And ((w >= 3) And (w <= 6)) Then 'wybrano komórkę z datą
d = Sheets("ROZL").Cells(w, k)
d = d + 1
Sheets("ROZL").Cells(w, k) = d
Else
MsgBox "wybierz komórkę z datą, aby ją zmienić"
End If
End Sub
Sub DataROZLPop()
w = Selection.Row
k = Selection.Column
If (k = 8) And ((w >= 3) And (w <= 6)) Then 'wybrano komórkę z datą
d = Sheets("ROZL").Cells(w, k)
d = d - 1
Sheets("ROZL").Cells(w, k) = d
Else
MsgBox "wybierz komórkę z datą, aby ją zmienić"
End If
End Sub
Sub dataROZLMNas()
w = Selection.Row
k = Selection.Column
If (k = 8) And ((w >= 3) And (w <= 6)) Then 'wybrano komórkę z datą
d = Sheets("ROZL").Cells(w, k)
mies = Month(d)
dni = Sheets("OBSŁUGA").Cells(mies, 16)
d = d + dni
Sheets("ROZL").Cells(w, k) = d
Else
MsgBox "wybierz komórkę z datą, aby ją zmienić"
End If
End Sub
Sub dataROZLMPop()
w = Selection.Row
k = Selection.Column
If (k = 8) And ((w >= 3) And (w <= 6)) Then 'wybrano komórkę z datą
d = Sheets("ROZL").Cells(w, k)
mies = Month(d) - 1
If mies = 0 Then mies = 12
dni = Sheets("OBSŁUGA").Cells(mies, 16)
d = d - dni
Sheets("ROZL").Cells(w, k) = d
Else
MsgBox "wybierz komórkę z datą, aby ją zmienić"
End If
End Sub
'do czego to miało służyć?
Sub RozliczenieZastępstwPUSTY()
kob = "Stwierdzam pod odpowiedzialnością służbową, że powyższe godziny odbyłam i dokonałam zapisu w dzienniku lekcyjnym."
fac = "Stwierdzam pod odpowiedzialnością służbową, że powyższe godziny odbyłem i dokonałem zapisu w dzienniku lekcyjnym."
dataOD = Sheets("ROZL").Range("H3")
dataDO = Sheets("ROZL").Range("H4")
Sheets("ROZL").Range("B6") = "Rozliczenie zastępstw (" & dataOD & " - " & dataDO & ")"
Sheets("OBSŁUGA").Columns("A:C").ClearContents
Sheets("ROZL").Range("C8:F37").ClearContents
Sheets("ROZL").Range("E38") = ""
Sheets("ROZL").Range("E39") = ""
'autmat czy pytać za każdym razem
'czy podgląd wydruku
CzyPodgląd = Sheets("OBSŁUGA").Range("E12")
nrnaucz = Sheets("OBSŁUGA").Range("E13")
naucz = Sheets("PAR").Cells(nrnaucz + 1, 2)
Sheets("ROZL").Range("B3") = naucz
Sheets("ROZL").Range("F3") = "Bobowa, dnia: " & CDate(Sheets("ROZL").Range("H6"))
Application.ScreenUpdating = False
For i = 8 To 37
Sheets("ROZL").Rows(i).RowHeight = 16.5
Next
Application.ScreenUpdating = True
If CzyPodgląd = True Then
ActiveWindow.SelectedSheets.PrintPreview
Else
ActiveWindow.SelectedSheets.PrintOut Copies:=1
End If
End Sub
Sub RozliczFiltrujDatami()
datOD = Sheets("ROZL").Range("H3")
datDO = Sheets("ROZL").Range("H4")
SkokKsiążka
krOD = ">=" & datOD
krDO = "<=" & datDO
Selection.AutoFilter Field:=2, _
Criteria1:=krOD, Operator:=xlAnd, _
Criteria2:=krDO
End Sub
'BRAKI w edzienniku ***************************************************
Sub BRAKI()
Dim Msg, Style, Title
Msg = "BRAKI w eDZIENNIKU" & Chr(13) & Chr(13) & _
"wykonaj następujące czynności:" & Chr(13) & _
"1. eDziennik - przygotuj dokument PDF z brakami" & Chr(13) & _
" Wydruki i zestawienia - Zestawienia Dyrektora - Kontrola - Braki w dziennikach" & Chr(13) & _
"2. Otwórz PDF z brakami, zaznacz wszystko CTRL+A i skopiuj CTRL+C" & Chr(13) & _
"3. Wklej skopiowane dane do zakładki BRA tego arkusza" & Chr(13) & _
" użyj przycisku WKLEJ" & Chr(13) & _
"4. Teraz możesz uruchomić wyszukiwanie braków" & Chr(13) & Chr(13) & _
"Czy na pewno wyszukać braki?"
Style = vbYesNo + vbCritical + vbDefaultButton1
Title = "BRAKI w eDzienniku"
wynik = MsgBox(Msg, Style, Title)
If wynik = vbYes Then
Sheets("BRA").Select
'KonwertujdoBRA
'SzukajBraków
End If
End Sub
'nowa wersja konwertowania
'tworzymy PDF
'otwieramy w ARXI
'zaznaczamy wszystko, kopiujemy i wklejamy do zakłądki zPDF
Sub WklejzPDF()
pdf = "BRA"
Sheets(pdf).Select
Cells.Select
Selection.ClearContents
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
End Sub
Sub KonwertujdoBRA()
On Error GoTo błąd
pdf = "BRA"
bra = "BRA"
'czyszczenie
Sheets(pdf).Select
Columns("B:Z").Select
Selection.ClearContents
Range("A1").Select
'szukamy ostatniego wiersza danych
w = 10000
Do
w = w - 1
Loop Until Sheets(pdf).Cells(w, 1) <> ""
wp = w
'a teraz od przodu
w = 1
w1 = 1
Do
wie = Sheets(pdf).Cells(w, 1)
r = Right(wie, 1)
If r = "x" Then
w1 = w1 + 1
Sheets(bra).Cells(w1, 2) = wie
'od razu rozdzielamy
'NAZWISKO - do nawiasu "("
naw = InStr(1, wie, "(")
naz = Left(wie, naw - 2)
Sheets(bra).Cells(w1, 3) = naz
'dwuliterowy skrót nazwiska
skr = Mid(wie, naw + 1, 2)
Sheets(bra).Cells(w1, 4) = skr
'PRZEDMIOT
'obcinamy nazwisko i skrót
'szukamy przecinka przedmiot i klasa
'szukamy spacji od tyłu
wip = Mid(wie, naw + 5, Len(wie))
prz = InStr(1, wip, ",")
nik = Left(wip, prz - 1)
spa = InStrRev(nik, " ", Len(nik))
pre = Left(nik, spa - 1)
Sheets(bra).Cells(w1, 5) = pre
'rozdzielamy klasę na klas i grupe
klg = Right(nik, Len(nik) - spa)
kig = InStr(1, klg, "|")
If kig > 0 Then
kla = Left(klg, kig - 1)
gru = Right(klg, Len(klg) - kig)
Else
kla = klg
gru = ""
End If
Sheets(bra).Cells(w1, 6) = kla
Sheets(bra).Cells(w1, 7) = gru
'DATA i LEKCJA
dil = Mid(wip, prz + 2, Len(wip))
dzi = Left(dil, 2)
mie = Mid(dil, 4, 2)
rok = Mid(dil, 7, 4)
Sheets(bra).Cells(w1, 8) = CInt(dzi)
Sheets(bra).Cells(w1, 9) = CInt(mie)
Sheets(bra).Cells(w1, 10) = CInt(rok)
Sheets(bra).Cells(w1, 11) = rok & "-" & mie & "-" & dzi
'LEKCJA numer
nrl = InStr(1, dil, "nr")
lek = Right(dil, Len(dil) - nrl - 2)
xx = InStr(1, lek, "x")
nrl = Left(lek, xx - 1)
Sheets(bra).Cells(w1, 12) = nrl
'ZLEPEK DO SZUKANIA
'może łatwiej szukać gdy stworzymy NAU+DAT+LEK
nau = Sheets(bra).Cells(w1, 3)
dat = Sheets(bra).Cells(w1, 11)
nrl = Sheets(bra).Cells(w1, 12)
zle = nau & " " & dat '& " " & nrl
Sheets(bra).Cells(w1, 13) = zle
'robimy też z numerem lekcji żeby było dokładnie wiadome
zle = nau & " " & dat & " " & nrl
Sheets(bra).Cells(w1, 14) = zle
End If
Sheets(bra).Range("A1") = wp - w
w = w + 1
Loop Until w = wp
'nazwy kolumn
Sheets(bra).Range("A1") = "PDF"
Sheets(bra).Range("B1") = "BRA"
Sheets(bra).Range("C1") = "NAU"
Sheets(bra).Range("D1") = "SKR"
Sheets(bra).Range("E1") = "PRZ"
Sheets(bra).Range("F1") = "KLA"
Sheets(bra).Range("G1") = "GRU"
Sheets(bra).Range("H1") = "DZI"
Sheets(bra).Range("I1") = "MIE"
Sheets(bra).Range("J1") = "ROK"
Sheets(bra).Range("K1") = "DAT"
Sheets(bra).Range("L1") = "LEK"
Sheets(bra).Range("M1") = "SZU"
Sheets(bra).Range("N1") = "SZN"
Sheets(bra).Range("O1") = "WYN"
Exit Sub
błąd:
MsgBox "błąd - dane niepoprawne"
End Sub
'szukamy braków
'PDF już przekonwertowany w arkuszu BRA
Sub SzukajBraków()
'tablica na wolne dni - szukamy podczas pierewszego sprawdzania księgi
Dim Twolne(100) As Variant
tw = 0 'liczba wolnych dni
bra = "BRA"
ksi = "KSIĘGA"
'wyczyścić barki
Sheets("BRA").Select
Columns("O:O").Select
Selection.ClearContents
Sheets("BRAKI").Select
Cells.Select
Selection.ClearContents
Range("A2").Select
'szukamy ostatniego wiersza danych
w = 10000
Do
w = w - 1
Loop Until Sheets(ksi).Cells(w, 2) <> ""
wx = w
'******************************************
'najpierw szukamy tych nauczycieli którzy powinni wpisać coś do dziennika
'nie ma znaczenia jaki symbol w KSIĘGA
'przelatujemy w KSIĘGA zapisy aż puste
w = 5
wb = 2
Do
Sheets("BRAKI").Cells(2, 7) = wx - w
ZAS = Sheets(ksi).Cells(w, 11)
'If ZAS = "ZAS" Or ZAS = "WSP" Or ZAS = "LzL" Then
dat = Sheets(ksi).Cells(w, 2)
kla = Sheets(ksi).Cells(w, 3)
gru = Sheets(ksi).Cells(w, 5)
lekcja = Sheets(ksi).Cells(w, 6)
'z numerem lekcji problem bo: 1,2 lub 1-3 badamy tylko pierwsze z lewej
'\ - dzielenie całkowite
For l = 1 To (Len(lekcja) + 1) \ 2
lek = DajLekcję(lekcja, l)
skr = Sheets(ksi).Cells(w, 8) 'nauczyciel, który powinien wpisać
'skrót nauczyciela trzeba zmienić na pełne nazwisko
Sheets("OBSŁUGA").Range("E13") = skr
nau = Sheets("OBSŁUGA").Range("E14")
'ZLEPEK DO SZUKANIA
zle = nau & " " & dat & " " & lek
'Do
'szukamy w kolumnie N w arkuszu BRA
Sheets("OBSŁUGA").Range("E15") = zle
jes = Sheets("OBSŁUGA").Range("E16")
If jes > 0 Then
Sheets("BRAKI").Cells(wb, 1) = wb - 1
Sheets("BRAKI").Cells(wb, 2) = dat
Sheets("BRAKI").Cells(wb, 3) = nau
Sheets("BRAKI").Cells(wb, 4) = kla & " " & gru
Sheets("BRAKI").Cells(wb, 5) = lek 'CStr(lek) 'Sheets(bra).Cells(jes, 12)
Sheets("BRAKI").Cells(wb, 6) = ZAS
Sheets(bra).Cells(jes, 15) = ZAS
wb = wb + 1
End If
'Loop Until jes = 0
Next l
'i jeszcze wolne dni do tablicy
wol = Sheets(ksi).Cells(w, 11)
If wol = "X" Then
tw = tw + 1
Twolne(tw) = dat
Twolne(0) = tw
End If
'End If
w = w + 1
Loop Until Sheets("KSIĘGA").Cells(w, 1) = ""
'nagłówki
Sheets("BRAKI").Range("A1") = "LP"
Sheets("BRAKI").Range("B1") = "DATA"
Sheets("BRAKI").Range("C1") = "NAUCZ"
Sheets("BRAKI").Range("D1") = "KLASA"
Sheets("BRAKI").Range("E1") = "GODZ"
Sheets("BRAKI").Range("F1") = "ZAST"
'**********************************************
'nie ma nauczycila w szkole i nie ma braku
'teraz szukamy tych nauczycieli, których nie ma w szkole
'ci nauczyciele mogą mieć pochylone i to nie jest brak
'nie ma znaczenia jaki symbol zastępstwa
w = 5
Do
Sheets("BRAKI").Cells(2, 7) = wx - w
ZAS = Sheets(ksi).Cells(w, 11)
'If ZAS = "BWD" Or ZAS = "LzL" Then
dat = Sheets(ksi).Cells(w, 2)
kla = Sheets(ksi).Cells(w, 3)
gru = Sheets(ksi).Cells(w, 5)
lekcja = Sheets(ksi).Cells(w, 6)
'na razie tylko pierwszy numer
For l = 1 To (Len(lekcja) + 1) \ 2
lek = DajLekcję(lekcja, l)
skr = Sheets(ksi).Cells(w, 7) 'nieobecny nauczyciel
'skrót nauczyciela trzeba zmienić na pełne nazwisko
Sheets("OBSŁUGA").Range("E13") = skr
nau = Sheets("OBSŁUGA").Range("E14")
'ZLEPEK DO SZUKANIA
zle = nau & " " & dat & " " & lek
'Do 'w pętli aż wyeliminuje wszystkie BWD z tego dnia
'znajduje tylko pierwszego a jeśli były grupy?
Sheets("OBSŁUGA").Range("E15") = zle
jes = Sheets("OBSŁUGA").Range("E16")
If jes > 0 Then
Sheets(bra).Cells(jes, 15) = "XXX"
wb = wb + 1
End If
'Loop Until jes = 0 'szukamy aż wszystkie znajdzie zapisy z tego dnia
Next l
'End If
w = w + 1
Loop Until Sheets("KSIĘGA").Cells(w, 1) = ""
'GoTo koniec
'szukamy ostatniego wiersza danych
w = 10000
Do
w = w - 1
Loop Until Sheets(bra).Cells(w, 2) <> ""
wx = w
'****************************************
'wpisane XXX ale tylko dla jednej grupy
'a jesli było kika to zostaje puste
'przelecieć i poprawić te same braki
w = 2
Do
Sheets("BRAKI").Cells(2, 7) = wx - w
br1 = Sheets("BRA").Cells(w, 14)
brx = Sheets("BRA").Cells(w, 15)
If brx = "XXX" Then 'może mić pochylone bo go nie było
br2 = Sheets("BRA").Cells(w + 1, 14)
If br1 = br2 Then Sheets("BRA").Cells(w + 1, 15) = "XXX"
End If
w = w + 1
Loop Until Sheets("BRA").Cells(w, 2) = ""
'*******************************************
'w księdze zapisano wolne dni i tych nie sprawdzamy
w = 2
Do
Sheets("BRAKI").Cells(2, 7) = wx - w
dat = Sheets("BRA").Cells(w, 11)
For tw = 1 To Twolne(0)
If dat = Twolne(tw) Then
Sheets("BRA").Cells(w, 15) = "X"
End If
Next tw
w = w + 1
Loop Until Sheets("BRA").Cells(w, 2) = ""
'*******************************************
'wstawianie pozostałych godzin
'sprawdziliśmy nauczycieli którzy zastępują
'sprawdziliśmy nauczycieli którzych niema wtedy w szkole
'reszta zapisów to BRAKI nie związane z zastępstawami
w = 2
lp = 1
Do
Sheets("BRAKI").Cells(2, 7) = wx - w
wyn = CStr(Sheets("BRA").Cells(w, 15)) 'rodzaj zastępstwa
If wyn = "" Then
lp = lp + 1
dat = Sheets("BRA").Cells(w, 11)
nau = Sheets("BRA").Cells(w, 3)
kla = Sheets("BRA").Cells(w, 6)
god = Sheets("BRA").Cells(w, 12)
prz = Sheets("BRA").Cells(w, 5)
Sheets("BRAKI").Cells(lp, 10) = lp - 1
Sheets("BRAKI").Cells(lp, 11) = dat
Sheets("BRAKI").Cells(lp, 12) = nau
Sheets("BRAKI").Cells(lp, 13) = kla
Sheets("BRAKI").Cells(lp, 14) = god
Sheets("BRAKI").Cells(lp, 15) = prz
End If
w = w + 1
Loop Until Sheets("BRA").Cells(w, 2) = ""
'nagłówki
Sheets("BRAKI").Range("J1") = "LP"
Sheets("BRAKI").Range("K1") = "DATA"
Sheets("BRAKI").Range("L1") = "NAUCZ"
Sheets("BRAKI").Range("M1") = "KLASA"
Sheets("BRAKI").Range("N1") = "GODZ"
Sheets("BRAKI").Range("M1") = "PRZEDMIOT"
koniec:
'sortowanie
Sheets("BRAKI").Range("C2").Select
ActiveWorkbook.Worksheets("BRAKI").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("BRAKI").Sort.SortFields.Add Key:=Range("C2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("BRAKI").Sort
.SetRange Range("B2:F1000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("BRAKI").Select
End Sub
Sub DrukujPozostałe()
w = 2
Do
w = w + 1
Loop Until Cells(w, 10) = ""
zakres = "J1:O" & CStr(w)
Range(zakres).Select
'Range("O1").Activate
Selection.PrintOut Copies:=1, Preview:=True
Range("B2").Select
End Sub
Sub DrukujBraki()
w = 2
Do
w = w + 1
Loop Until Cells(w, 1) = ""
zakres = "A1:F" & CStr(w)
Range(zakres).Select
Selection.PrintOut Copies:=1, Preview:=True
Range("B2").Select
End Sub
Sub SkokBraki()
Sheets("BRAKI").Select
End Sub
'wybiera konkretną lekcję z zapisu "1,2,4,5,11"
'rozdzielone przecinkiem
'ale jeszcze nie uwzględnione
Function DajLekcję(lek, nr As Variant) As Variant
On Error GoTo błąd
lekcja = lek
For i = 1 To nr
p = InStr(1, lekcja, ",")
If p > 0 Then
l = Left(lekcja, p - 1)
lekcja = Mid(lekcja, p + 1, 100)
Else
l = lekcja
i = nr
End If
Next i
DajLekcję = l
Exit Function
błąd:
DajLekcję = Left(lek, 1)
End Function
Sub xxx()
MsgBox DajLekcję("0,3,11", 4)
End Sub
'*********** nie używane
'Dim ocell As Range
'i = 0
'For Each ocell In Selection
' i = i + 1
' w = ocell.Row
'Next
Sub aaa()
'MsgBox ActiveSheet.PageSetup.FirstPageNumber
'MsgBox ActiveWindow.SelectedSheets
'ActiveSheet.PageSetup.PrintArea = zakres
'ActiveWindow.SelectedSheets.PrintPreview
End Sub
'w obsłudze są klasy po jednym wpisie w kolumnie J
'a my do kolumny K wrzucamy klasy rozdzielone
Sub KlasyRozdziel()
w = 1
wi = 1
k = 10 'J
Do
klasa = Sheets("OBSŁUGA").Cells(w, k)
łącznik = Mid(klasa, 3, 1)
If łącznik = "-" Then 'trzeba rozdzielić klasy
klasa1 = Mid(klasa, 1, 2) & Mid(klasa, 5, 10)
Sheets("OBSŁUGA").Cells(wi, 11) = klasa1
'Sheets("OBSŁUGA").Cells(wi, 14) = Sheets("OBSŁUGA").Cells(w, 13)
wi = wi + 1
klasa2 = Mid(klasa, 1, 1) & Mid(klasa, 4, 10)
Sheets("OBSŁUGA").Cells(wi, 11) = klasa2
'Sheets("OBSŁUGA").Cells(wi, 14) = Sheets("OBSŁUGA").Cells(w, 13)
wi = wi + 1
Else 'przepisujemy klasę
Sheets("OBSŁUGA").Cells(wi, 11) = klasa
'Sheets("OBSŁUGA").Cells(wi, 14) = Sheets("OBSŁUGA").Cells(w, 13)
wi = wi + 1
End If
w = w + 1
Loop Until Sheets("OBSŁUGA").Cells(w, k) = ""
'Sheets("OBSŁUGA").Columns("J:J").ClearContents
WybierzPoJednym 11, 12
End Sub
'tworzy w kolumnie Z pojedyncze daty
Sub UnikatoweDaty()
'wyczyść kolumnę
Columns("Z:Z").Select
Selection.ClearContents
'posortuj daty
Range("A5:L10000").Sort Key1:=Range("B5"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'kopiowanie unikatowych do Z
Range("B5:B10000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("Z5"), Unique:=True
AutoFiltrONOFF
End Sub
Sub FiltrDataNauczyciel()
Selection.AutoFilter Field:=2
Selection.AutoFilter Field:=2, Criteria1:="2011-02-17"
Range("A4:L13").Sort Key1:=Range("F4"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End Sub
'nie używane
Sub DrukujKartaPOP()
zakres = "$B$2:$E$150"
Sheets("KARTA").Range("E2") = Sheets("KARTA").Range("G2")
ActiveSheet.PageSetup.PrintArea = zakres
ActiveWindow.SelectedSheets.PrintPreview
ActiveSheet.PageSetup.PrintArea = ""
Dim Msg, Style, Title
Msg = "NUMERY STRON KSIĘGI ZASTĘPSTW" & Chr(13) & Chr(13) & _
"Czy ustawić kolejny numer?"
Style = vbYesNo + vbCritical + vbDefaultButton2
Title = "NUMERY"
wynik = MsgBox(Msg, Style, Title)
If wynik = vbYes Then
NastępnaStrona
End If
Cells(1, 5).Select
'SkokKsiążka
End Sub
'tak wcześniejwyodrębniało ale robiło byki
'i posortować, bo zostawiało puste!
'Sheets("OBSŁUGA").Select
'sortowanie nieobecnych
'Range("A1:A1000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("C1"), Unique:=True
'Range("C1:C1000").Sort _
'Key1:=Range("C1"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom , DataOption1:=xlSortNormal
'sortowanie zastępców
'Range("F1:F1000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("G1"), Unique:=True
'Range("G1:G1000").Sort _
'Key1:=Range("G1"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom , DataOption1:=xlSortNormal
'sortowanie klas
'Range("I1:I1000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("J1"), Unique:=True
'Range("J1:J1000").Sort _
'Key1:=Range("J1"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom , DataOption1:=xlSortNormal
'Sheets(arkusz).Select
Public zmiana As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
If zmiana = False Then
adres = Target.Address
Sheets("OBSŁUGA").Cells(1, 25) = adres
wie = Sheets("OBSŁUGA").Cells(2, 25)
kol = Sheets("OBSŁUGA").Cells(3, 25)
If wie = 4 And kol <> 2 Then
zmiana = True
Sheets("KSIĘGA").Cells(4, kol) = Sheets("OBSŁUGA").Cells(kol, 26)
'If kol = 2 Then Sheets("KSIĘGA").Cells(4, kol) = Date
Sheets("OBSŁUGA").Cells(1, 25) = "A1"
MsgBox "nie wolno zmieniać tych komórek"
zmiana = False
End If
End If
End Sub
Jeśli komuś wydaje się, że ten kod, to coś strasznie skomplikowanego, to chciałem poinformować, że dla programisty z 30-letnim doświadczeniem nie jest on specjalnie zawiły i pokrętny. Prawdziwe problemy pojawiają się w trakcie tzw. "odpluskwiania", czyli wyszukiwania i poprawiania błędów oraz sprawiania, że program będzie - jak to mówią programiści - "idioto odporny", czyli, że nie będzie się zawieszał i będzie poprawnie reagował na różne wymyślne u nieuprawnione działania użytkownika.
Wacław Libront
