Drukuj

zast1

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:

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.

zast2 zast2 zast2 zast2 zast2 zast2


 

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