Hi,
das kopierst du in ein Modul rein und führst es dann immer aus, wenn du was eingetragen hast. Da immer alle Einträge abgearbeitet werden immer erst anstarten, wenn du alle neuen Einträge eingegeben hast.
Kann abhängig von der Anzahl der Einträge auch einmal länger dauern, in der Zwischenzeit nicht in Excel rumklicken.
Die Überschriften in deinen Teilblättern werden auch gelöscht, also die müßtest du noch im Code einfügen damit du sie nicht immer neu eintippen mußt.
Zu ändern sind:
- die Namen deiner Blätter
- die Startzeile wo deine Einträge anfangen (Annahme in allen Blättern gleich sonst mußt du das ändern)
- die Spalte in der dein Kriterium steht
Hinzuzufügen:
- Überschriften und Formatierung der Überschriften für die Teilblätter
Achtung:
- Kopiert wird die ganze Zeile, ich gehe also davon aus, dass die Spaltenanzahl und Position in allen Blättern gleich ist.
- Unbedingt an einer Kopie erst einmal probieren und überprüfen ob alles paßt. Auf jeden Originaldatei behalten.
- Keine Garantie falls es nicht funktioniert oder Fehler verursacht. Habs mal schnell runtergeschrieben, läßt sich bestimmt noch verbessern.
Option Explicit
Private Const row_start As Integer = 2
Private Const col_kriterium As Integer = 9
Sub Start()
Dim cur_sheet As Excel.Worksheet
Dim main_sheet As Excel.Worksheet
Dim good_sheet As Excel.Worksheet
Dim bad_sheet As Excel.Worksheet
Dim normal_sheet As Excel.Worksheet
Dim cnt_row As Long
Dim kriterium As String
Dim cur_row_g As Long
Dim cur_row_b As Long
Dim cur_row_n As Long
Dim cnt As Integer
cur_row_g = row_start
cur_row_b = row_start
cur_row_n = row_start
Set main_sheet = ThisWorkbook.Worksheets("Zusammenfassung")
Set good_sheet = ThisWorkbook.Worksheets("gut")
Set bad_sheet = ThisWorkbook.Worksheets("schlecht")
Set normal_sheet = ThisWorkbook.Worksheets("normal")
good_sheet.Cells.ClearContents
bad_sheet.Cells.ClearContents
normal_sheet.Cells.ClearContents
cnt_row = row_start
Do Until (main_sheet.Cells(cnt_row, 1)) = ""
kriterium = UCase(main_sheet.Cells(cnt_row, col_kriterium))
Select Case kriterium
Case "G"
main_sheet.Rows(cnt_row & ":" & cnt_row).Copy
good_sheet.Activate
good_sheet.Rows(cur_row_g & ":" & cur_row_g).Select
good_sheet.Paste
cur_row_g = cur_row_g + 1
Case "S"
main_sheet.Rows(cnt_row & ":" & cnt_row).Copy
bad_sheet.Activate
bad_sheet.Rows(cur_row_b & ":" & cur_row_b).Select
bad_sheet.Paste
cur_row_b = cur_row_b + 1
Case "N"
main_sheet.Rows(cnt_row & ":" & cnt_row).Copy
normal_sheet.Activate
normal_sheet.Rows(cur_row_n & ":" & cur_row_n).Select
normal_sheet.Paste
cur_row_n = cur_row_n + 1
Case Else
MsgBox "Kein (richtiges) Kennzeichen eingetragen. Reihe " & cnt_row
End Select
cnt_row = cnt_row + 1
Loop
End Sub
|