Blätter zusammenfassen

Hallo zusammen,
nachdem mir hier beim letzten mal schon so super geholfen wurde, hoffe ich, ihr könnt mir noch einmal helfen.
Ich habe für meinen Betrieb eine Stundenaufschreibung angelegt. Hier soll jeder Mitarbeiter im jeweiligen Tabellenblatt seine Tätigkeiten eintragen. Die Blätter sind nach der 4-stelligen Personalnummer benannt und entsprechen alle der gleichen Struktur. Beim Öffnen der Mappe öffnet sich ein Formular, in welches der Mitarbeiter seine Nummer eingibt und bestätigt. Daraufhin wird das ensprechende Blatt selektiert und die erste freie Zeile angesprungen. Soweit funktioniert alles, wie ich mir das vorstelle. Um die Einträge jedoch sinnvoll auswerten zu können, habe ich ein weiteres Blatt "Zusammenfassung" angelegt. Hier sollen automatisch alle Einträge von allen Mitarbeitern zusammengefasst werden. Sprich alle Zeilen sollen in dieses eine Blatt kopiert werden. In den einzelnen Blättern sollen die Zeilen erhalten bleiben.
Ich habe bereits in Excel gesucht, ob es eine solche Funktion bereits gibt, aber bin nicht fündig geworden. Nun wollte ich es in VBA umsetzen. Hierzu habe ich einen Button "Aktualisieren" in die Übersicht eingefügt.
Leider bin ich noch ein ziemlicher Anfänger und komme nicht wirklich zurecht. Kann mir hier vielleicht jemand einen Denkanstoß oder ein Skript zur Orientierung geben. Sicher kann man das doch mit einer while Schleife umsetzen oder?
Die Datei ist unten angehängt.
MFG Martin
https://www.herber.de/bbs/user/104701.xlsm

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Mach() Dim WS1 As Worksheet, WS2 As Worksheet Dim letzteZeile As Long Set WS1 = ThisWorkbook.Worksheets("Zusammenfassung") For Each WS2 In ThisWorkbook.Worksheets If WS2.Name WS1.Name And WS2.Name "Eingabefelder" Then letzteZeile = WS2.Cells(WS2.Rows.Count, 4).End(xlUp).Row If letzteZeile > 4 Then _ WS2.Rows("5:" & letzteZeile).Copy WS1.Cells(WS1.Rows.Count, 1).End(xlUp).Offset(1, 0) End If Next WS2 End Sub

Sub Mach() Dim WS1 As Worksheet, WS2 As Worksheet Dim letzteZeile As Long Set WS1 = ThisWorkbook.Worksheets("Zusammenfassung") Application.ScreenUpdating = False WS1.Rows("5:10000").EntireRow.Delete For Each WS2 In ThisWorkbook.Worksheets If WS2.Name WS1.Name And WS2.Name "Eingabefelder" Then letzteZeile = WS2.Cells(WS2.Rows.Count, 4).End(xlUp).Row If letzteZeile > 4 Then _ WS2.Rows("5:" & letzteZeile).Copy WS1.Cells(WS1.Rows.Count, 1).End(xlUp).Offset(1, 0) End If Next WS2 End Sub

Beliebteste Forumthreads (12 Monate)

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread