Hallo zusammen und schonmal danke im voraus für die Hilfe und Zeit,

ich arbeite derzeit an einer Datei welche automatisch Stundenpläne erstellt. Dabei stecke ich gerade fest weil ich einen Fehler nicht finde und hoffe das hier ein anderer Blickwinkel vielleicht helfen kann.

Die Datei hat unter anderem die Reiter "Semesterplanung" und "Wochenplanung". In der Semesterplanung stehen alle Kalenderwochen eines Semesters, alle Fächer und pro Woche 4 Spalten für Klassen. Wenn das Fach in der Woche bei der Klasse unterrichtet wird, steht in der entsprechenden Zelle wo sich die Klasse und das Fach kreuzen die Stundenzahl, in allen anderen Zellen der Spalte steht nichts. Auf dem Reiter Wochenplan sollen nun nur noch die Fächer eingetragen werden, die für die gerade relevante Woche akut sind. Dabei sollen erst die Fächer von Klasse 1 eingetragen werden, dann die von Klasse 2, 3 und 4 (nacheinander). Dabei sollen Fächer die bereits in einer der vorigen Klassen ebenfalls eingetragen sind in der gleichen Spalte auftauchen. Also wenn ein Fach in Klasse 1 und 3 unterrichtet wird, sollen beide in der gleichen Spalte stehen. Bei Klasse 2 darf in der Spalte dann nur ein Fach stehen das weder in 1 noch in 3 unterrichtet wird.

Ich habe dafür folgenden Code geschrieben (der erstmal nur Klasse 1 und 2 füllt), das Problem ist er trägt bei Klasse 2 schon nichts mehr ein und verliert sich in der Schleife wenn er die Zeile für Klasse 2 finden soll.

Sub Wochenplanung()
    Dim Klasse As Integer
    Dim Fach As String
    Dim Stundenzahl As Integer
    Dim Spalte As Integer
    Dim Zeile As Integer
    Dim Woche As Integer
    Dim Wochenplanzeile As Integer
    Dim Hörsaal As Integer
    Dim Anzahl_Klasse As Integer
    Dim Vorhanden As Integer
    
    
    
    
    'Teil 1: Die Fächer für die Klassen ermitteln die in der Woche unterrichtet werden sollen
    
    Hörsaal = 1 'Immer mit Klasse 1 beginnen
    Anzahl_Klassen = Range("anzahl_klassen").Value
    Spalte = 36 'Die Basis für die Berechnung der Spalte
    'Die Spalte für Klasse 1 ermitteln
    Woche = Range("aktuelle_woche").Value - 1 'Die aktuelle Woche bezieht sich auf die nächste, noch nicht geplante Woche im Semesterplaner
    Spalte = Spalte + 8 * Woche 'Der Faktor 8 rührt daher das zwei Kalenderwochen in der Semesterplanung genau 8 Spalten auseinander liegen
    Vorhanden = 0
    
    'Auf den Reiter Semesterplanung wechseln
    Application.ScreenUpdating = False
    Sheets("Semesterplanung").Activate
    
    'Zur Sicherheit alle Daten im Reiter Wochenplanung löschen
    Sheets("Wochenplanung").Range("A4:H9").Value = ""
    
    'Zuerst die nötigen Fächer zusammentragen
    
    'Alle Fächer je nach Klasse zusammenstellen
    Do Until Hörsaal > Anzahl_Klassen
    
        Zeile = 6 'Die oberste Zeile in der Semesterplanung
        Wochenplanzeile = 4 'Der erste Hörsaal wird von oben nach unten eingetragen
        
        'Die folgende Sequenz durchlaufen bis zur letzten erlaubten Wochenplanungszeile oder dem letzten Fach (mehr als 100 Fächer sind im Semesterplan nicht vorgesehen)
        Do Until Wochenplanzeile = 10 Or Wochenplanzeile = 3
            'Die nächste Zeile mit Stundenzahl ermitteln
            Do Until Cells(Zeile, Spalte).Value <> "" Or Zeile > 105
                Zeile = Zeile + 1
            Loop
        
            'Das Fach aus der ermittelten Zeile speichern
            Fach = Cells(Zeile, 7).Value

            'Prüfen ob das Fach in einem der anderen Hörsäle schonmal eingetragen wurde, falls ja das Fach in die gleiche Zeile packen
'HIER passiert der Fehler, aus dieser Schleife kommt VBA nicht mehr raus. Zur Erklärung: Der Platz für Fächer ist limitiert auf die Zeilen 4-9.
            If Hörsaal = 2 Then
                Wochenplanzeile = 9
                Do Until Sheets("Wochenplanung").Cells(Wochenplanzeile, 1).Value = Fach Or Wochenplanzeile = 3
                    Wochenplanzeile = Wochenplanzeile - 1
                Loop
                If Sheets("Wochenplanung").Cells(Wochenplanzeile, 1).Value = Fach Then
                    Vorhanden = 1
                End If
            End If
            
            'Sofern das Fach noch nicht vorhanden war, die unterste leere Zeile wählen
            If Vorhanden = 0 And Hörsaal > 1 Then
                Wochenplanzeile = 9
                Do Until Sheets("Wochenplanung").Cells(Wochenplanzeile, (Hörsaal * 2) - 1).Value = "" Or Wochenplanzeile = 3
                    Wochenplanzeile = Wochenplanzeile - 1
                Loop
            End If

            'Das Fach speichern
            Sheets("Wochenplanung").Cells(Wochenplanzeile, (Hörsaal * 2) - 1).Value = Fach
            
            'Die Menge an Stunden speichern
            Stundenzahl = Cells(Zeile, Spalte).Value
            Sheets("Wochenplanung").Cells(Wochenplanzeile, Hörsaal * 2).Value = Stundenzahl / 2 'Durch 2 geteilt weil an der HSB immer Doppelstunden abgehalten werden
            
            'Das nächste Fach in der Zeile darunter speichern wenn es sich um Hörsaal 1 handelt
            If Hörsaal = 1 Then
                Wochenplanzeile = Wochenplanzeile + 1
            End If
            
            'Mindestens eine Zeile im Semesterplan weiter gehen
            Zeile = Zeile + 1
        
        Loop
        
        'Sofern weniger Stunden in dieser Woche enthalten sind als maximal möglich einen Dummy für die restlichen einfügen
        If Sheets("Wochenplanung").Cells(10, 2 * Hörsaal).Value < Sheets("Semesterplanung").Cells(1, Spalte).Value / 2 Then
            Sheets("Wochenplanung").Cells(9, 2 * Hörsaal).Value = 0
            Sheets("Wochenplanung").Cells(9, (2 * Hörsaal) - 1).Value = "Dummy"
            Sheets("Wochenplanung").Cells(9, 2 * Hörsaal).Value = (Sheets("Semesterplanung").Cells(1, Spalte).Value / 2) - Sheets("Wochenplanung").Cells(10, 2 * Hörsaal).Value
        End If
        
        'Zum nächsten Hörsaal wechseln
        Hörsaal = Hörsaal + 1
        'Die Spalte des nächsten Hörsaal im Semesterplan ist 2 Spalten weiter rechts
        Spalte = Spalte + 2
    
    Loop
       
    'Sicherung falls keine Fächer eingetragen wurden
    If Sheets("Wochenplanung").Cells(4, 1).Value = "" Then
        Mldng = MsgBox("Es gibt keine Fächer für die Wochenplanung. Bitte erst die Semesterplanung abschließen", vbOKOnly, "Vorgangsfehler")
        Exit Sub
    End If
    
    'Teil 2: Die Fächer mit dem Simplex-Algorithmus zuteilen
    Call Stundenplan
    
    'Zurück zum Reiter Wochenplanung wechseln
    Sheets("Stundenpläne").Activate
    Application.ScreenUpdating = True
End Sub