Mit VBA Zeilen in neue Register kopieren

Ein Tabellenblatt soll nach einem bestimmten Kriterium durchsucht werden. Immer wenn das Suchkriterium gefunden wird, soll die Zeile kopiert und in ein neues Tabellenblatt eingefügt werden. Dies soll solange geschehen bis alle Zeilen durchsucht worden sind.
Im Detail soll dies wie folgt funktionieren:
In dem Register PPL stehen alle benötigen Informationen zu den einzelnen Projekten. In Zeile 15 sind die Spalten als Spaltenkopf benannt. Ab Zeile 16 werden die Projekte mit den relevanten Daten eingetragen. Die Datei wird monatlich aktualisiert. Neu hinzukommende Projekte werden am Ende der Liste ergänzt. Abgeschlossene Projekte werden im Feld AC mit der Bemerkung erledigt versehen. Die jeweilige Zeile bleibt im Register PPL erhalten.
Pro Mitarbeiter habe ich ein eigenes Register angelegt (MA 1 bis MA 5). Folgende Daten je Mitarbeiter sollen aus dem Register PPL in das Mitarbeiter Register automatisch übertragen werden, sofern im Feld AC Bemerkung nicht erledigt steht:
Projektname (Register PPL, D15 wird Register z.B. MA 1, A1)
Projekt-ID (Register PPL, C15 wird Register z.B. MA 1, A2)
Phase (Register PPL, B15 wird Register z.B. MA 1, A3)
ABCL (Register PPL, AB15 wird Register z.B. MA 1, A4)
Start (Register PPL, U15 wird Register z.B. MA 1, A5)
Dauer (Register PPL, V15 wird Register z.B. MA 1, A6); nur den Wert eintragen
Die Daten sollen jeweils ab der zweiten Zeile eingetragen werden. Hat z.B. ein Mitarbeiter 8 Projekte, dann sollen in seinem Register diese 8 Projekte nacheinander - ohne Leerzeile - erscheinen. Die Zeilen sollen zuerst aufsteigend nach der Spalte E Start, als zweites aufsteigend nach Spalte F Dauer, sortiert werden.
Für die anderen Mitarbeiter soll dies analog in den entsprechenden Mitarbeiter Registern (MA 2 bis MA 5) geschehen.
In den beiden Registern Bsp. Daten Soll MA und Bsp. Diagramm Soll MA habe ich das gewünschte Ergebnis schon einmal von Hand für MA 3 eingetragen.
P.S.: Für die Diagramme muß nichts gemacht werden. Ist alles schon vorbereitet.
Hier die Datei:
https://www.herber.de/bbs/user/62294.xls

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Andreas,
hier ein Beispielcode
Gruß
Franz


Sub MA_Daten()
Dim wksMA As Worksheet, lngZeileMA As Long, strNameMA As String
Dim wksPPL As Worksheet, lngZeilePPL As Long, lngI As Long
Dim arrMA
'Array mit den Mitarbeiternamen (muss mit den Blattnamen übereinstimmen!)
arrMA = Array("MA 1", "MA 2", "MA 3", "MA 4", "MA 5")
Set wksPPL = Worksheets("PPL")
'Mitarbeiterblätter zurücksetzen
For lngI = LBound(arrMA) To UBound(arrMA)
strNameMA = arrMA(lngI)
If fncWorkSheetCheck(wb:=ActiveWorkbook, strWsName:=strNameMA) = True Then
Set wksMA = Worksheets(arrMA(lngI))
With wksMA
lngZeileMA = .Cells(.Rows.Count, 1).End(xlUp).Row
'Inhalte in Spalten A bis F ab Zeile 2 löschen
If lngZeileMA >= 2 Then
.Range(.Cells(2, 1), .Cells(lngZeileMA, 6)).ClearContents
End If
End With
Else
MsgBox "Für Mitarbeiter """ & arrMA(lngI) & """ ist noch kein Auswerteblatt angelegt!"
End If
Next
With wksPPL
For lngZeilePPL = 16 To .Cells(.Rows.Count, 1).End(xlUp).Row
'Spalte AC (29) prüfen
If LCase(.Cells(lngZeilePPL, 29))  "erledigt" Then
strNameMA = .Cells(lngZeilePPL, 7) 'Mitarbeitername Spalte G
If strNameMA  "" Then
If fncWorkSheetCheck(wb:=ActiveWorkbook, strWsName:=strNameMA) = True Then
Set wksMA = Worksheets(strNameMA)
With wksMA
'nächste freie Zeile im Mitarbeiterblatt
lngZeileMA = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(lngZeileMA, 1).Value = wksPPL.Cells(lngZeilePPL, 4).Value 'Projektname
.Cells(lngZeileMA, 2).Value = wksPPL.Cells(lngZeilePPL, 3).Value 'Projekt-ID
.Cells(lngZeileMA, 3).Value = wksPPL.Cells(lngZeilePPL, 2).Value 'Phase
.Cells(lngZeileMA, 4).Value = wksPPL.Cells(lngZeilePPL, 28).Value 'ABCL
.Cells(lngZeileMA, 5).Value = wksPPL.Cells(lngZeilePPL, 21).Value 'Start
.Cells(lngZeileMA, 6).Value = wksPPL.Cells(lngZeilePPL, 22).Value 'Dauer
End With
Else
MsgBox "Für Mitarbeiter """ & strNameMA & """ ist noch kein Auswerteblatt angelegt!"
End If
End If
End If
Next
End With
'Mitarbeiterblätter sortieren
For lngI = LBound(arrMA) To UBound(arrMA)
strNameMA = arrMA(lngI)
If fncWorkSheetCheck(wb:=ActiveWorkbook, strWsName:=strNameMA) = True Then
Set wksMA = Worksheets(arrMA(lngI))
With wksMA
lngZeileMA = .Cells(.Rows.Count, 1).End(xlUp).Row
'Inhalte in Spalten A bis P ab sortieren
If lngZeileMA >= 3 Then
With .Range(.Cells(1, 1), .Cells(lngZeileMA, 16))
.Sort key1:=.Range("E1"), order1:=xlAscending, _
key2:=.Range("G1"), order2:=xlAscending, header:=xlYes
End With
End If
End With
Else
MsgBox "Für Mitarbeiter """ & arrMA(lngI) & """ ist noch kein Auswerteblatt angelegt!"
End If
Next
End Sub
Function fncWorkSheetCheck(wb As Workbook, strWsName As String) As Boolean
Dim objWs As Worksheet
For Each objWs In wb.Worksheets
If LCase(objWs.Name) = LCase(strWsName) Then
fncWorkSheetCheck = True
Exit For
End If
Next
End Function

Beliebteste Forumthreads (12 Monate)

Mit VBA Zeilen in neue Register kopieren

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

323 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Mit VBA Zeilen in neue Register kopieren

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

323 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread