Daten finden und übertragen

Hallo zusammen,
ich habe ein Sortier/Abfrageproblem in einer Unterrichtsplanung. Bei zwei Abfragen stehe ich gerade auf dem Schlauch. In der Datei befindet sich in Tabelle1 die Unterrichtsplanung, die mit einer UserForm gefüllt wird. Im Dateibeispiel sollen die roten Gruppen mit den Angaben Datum, Name Lehrkraft, Gruppenname, Inhalt des Unterrichts, Raum wie im Beispiel Tabelle4 erscheinen. Gruppenname, Inhalt des Unterrichts, Raum funktionieren wie in Tabelle3 zu sehen. Modul1 überträgt KW2 aus Tabelle1 mit Hilfsspalten in Tabelle2. Modul2 findet die roten Gruppen und überträgt mit Offset Gruppenname, Inhalt des Unterrichts und Raum in Tabelle3. Name der Lehrkraft und Datum wie in Beispiel Tabelle4 stellen mein Problem dar. Idee ist das Einfügen von Hilfszeilen wie in Tabelle "Hilfszeilen", dann könnte zumindest die Lehrkraft mit Offset übertragen werden. Datum natürlich noch nicht. In Tabelle1 sind alle anderen Farben der Gruppen mit bedingter Formatierung erstellt, rot nicht, sonst funktioniert es ja nicht.
Das bisherige System ist sag ich mal bieder, aber es funktioniert und ist schnell genug.
Ihr seid Profis, darum bitte ich euch um Hilfe das Projekt fertigstellen zu können und damit etwas zu lernen.
Vielen Dank und Grüße vorab.
Datei: https://www.herber.de/bbs/user/157496.xlsm
Hans-Jörg

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Hans-Jörg!
Ich hab mit deinen ersten Gehversuchen nicht weiter auseinandergesetzt.
Stattdessen hab ich was neues, kürzeres, schickeres gebaut.
Bei Listen die Werte alle einzeln rüberzukopieren mag Schritt für Schritt nachvollziehbarer sein, bremst aber die Ausführung.
Statt dessen werden mit Arrays gearbeitet. Dies dann am ende in 1 Schritt eingefügt werden, der Bereich muss aber die exakte Größe haben.


Sub rote_übertragen()
    
    Dim arr_zähler As Long 'initial immer 0
    Dim cl As Range
    Dim rng As Range
    Set rng = Sheets("Tabelle1").Cells.SpecialCells(xlConstants) 'jede gefüllte Zelle
    
    ReDim plan_arr(1 To 999, 1 To 6) As Variant
    
    For Each cl In rng
    
        If cl.Interior.ColorIndex = 3 Then 'wenn die Zelle rot ist
            Datum = Cells(2, cl.Column) 'immer zeile 2
            offset_Z = 1
            Do Until Cells(cl.Row - offset_Z, 1) = "Lehrkraft"
                offset_Z = offset_Z + 1
            Loop
            Lehrkraft = Cells(cl.Row - offset_Z, cl.Column)
            Inhalt = cl.Offset(1, 0)
            Raum = cl.Offset(2, 0)
            
            'array füllen
            arr_zähler = arr_zähler + 1
            plan_arr(arr_zähler, 1) = Format(Datum, "dd.mm.YY")
            plan_arr(arr_zähler, 2) = Lehrkraft
            plan_arr(arr_zähler, 3) = cl.Value
            plan_arr(arr_zähler, 4) = cl.Offset(0, -1)
            plan_arr(arr_zähler, 5) = Inhalt
            plan_arr(arr_zähler, 6) = Raum
        End If
    Next cl
    'Array einfügen in Tabellenblatt
    Sheets("Tabelle3").Range("A1:F999") = plan_arr
End Sub

Schau es dir mal an
Gruß, MCO

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

155 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Daten finden und übertragen

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

155 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread