Grüezi Maik
Danke für die Blumen - aber heute ging es auf Arbeit hoch her und ich kam zu nix anderem (was ja eigentlich ein gutes Zeichen ist
).
Hier aber nun die erste 'finale' Version des Codes - bitte den bisherigen komplett dadurch ersetzen.
Nun wird neben dem Wert 5 auch auf die 1 geprüft, wobei der Code davon ausgeht, dass Du zuvor alle abgearbeiteten Zeilen mit einer '0' markiert hast und dann die Formel exakt in Zelle K1 (Z1S10) schreibst (diese Adresse können wir noch nach Belieben anpassen, resp. das ist nun eingebaut, Du kannst einfach ganz zu Beginn im Code diese Adresse vorgeben).
Der Vorteil der exakten Zelle ist, dass der Code nach dem Ablaufen die Formel in dieser Zelle gleich noch löscht und so das ganze Makro deaktiviert ist, bis Du es das nächste Mal durch Einfügen der Formel wieder anstösst.
Wird die 1 gefunden so heisst das, dass es noch weitere Posten zu bearbeiten gilt, die Zeilen ab Zeile 10 bis zu dieser 1 werden ins Backup verschoben und eben die Funktion wird gelöscht.
Wird keine 1 mehr gefunden wird nach der 6 gesucht und alle Zeilen von Zeile 10 bis zu dieser 6 werden ins Backup verschoben. Dann wird eine Meldung ausgegeben, dass die Verarbeitung abgeschlossen ist.
Triggerst Du dann das Makro erneut wird die Meldung ausgegeben, dass es keine Daten für die Verarbeitung mehr gibt.
Die Mappe wird auch nach jedem Durchlauf und Verschieben von Zeilen direkt gespeichert (ausser im letzten Fall, wenn es nichts mehr zu verarbeiten gibt.
So hast Du dann ein flexibles System, mit dem Du interaktiv deine Liste abarbeiten und nach Belieben unterbrechen kannst.
Vermutlich wird noch das eine oder andere Fehler-Handling erforderlich sein, aber ich denke, im Grossen und Ganzen sollte der Code so einsatzfähig sein.
Hier die Zeilen, bitte teste mal und melde dich anschliessend zu den Ergebnissen:
Code:
Option Explicit
Private Sub Worksheet_Calculate()
'------------------------------------------------------------
' Procedure : Worksheet_Calculate
' Author : t.ramel@mvps.org
' Date : 04.05.2011
' Revised : 06.05.2011
' Purpose : Prüft Schnittliste auf erfolgte Verarbeitung
' und erstellt Backup der abgearbeiteten Zeilen
'------------------------------------------------------------
On Error GoTo ErrorHandler
Application.EnableEvents = False
Dim lngRow As Long
Dim ws As Worksheet
Dim strFormel As String
'Prüfen ob Zahl 5 in Zeile 8 steht, ansonsten verschieben
If WorksheetFunction.CountIf(Range("A:A"), 5) > 0 Then
'Zelle in der die Trigger-Formel steht definieren
strFormel = "K1"
lngRow = Range("A:A").Find(What:=5, _
After:=Range("A1"), _
LookIn:=xlFormulas, _
LookAt:=xlWhole).Row
If lngRow > 8 Then
Rows(lngRow).Copy Rows(8)
Rows(lngRow).Delete
'Prüfen ob Backup-Tabelle existiert
For lngRow = 1 To ThisWorkbook.Worksheets.Count
If Worksheets(lngRow).Name = "Schnittliste_Backup" Then
Set ws = Worksheets("Schnittliste_Backup")
Exit For
End If
Next lngRow
If ws Is Nothing Then
'wenn nicht, Backup-Tabelle anlegen und Zeilen 1:9 kopieren
Set ws = Worksheets.Add(After:=Worksheets(Sheets.Count))
ws.Name = "Schnittliste_Backup"
lngRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row + 1
Me.Rows("1:9").Copy ws.Range("A1")
Me.Activate
Else
'wenn ja, Backup-Tabelle löschen und Zeilen 1:9 kopieren
ws.UsedRange.ClearContents
lngRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row + 1
Me.Rows("1:9").Copy ws.Range("A1")
End If
'Formel löschen und Mappe speichern
Range(strFormel).ClearContents
ws.Range(strFormel).ClearContents
ThisWorkbook.Save
End If
End If
'Prüfen ob Zahl 1 in Spalte A enthalten ist
If WorksheetFunction.CountIf(Range("A:A"), 1) > 0 Then
lngRow = Range("A:A").Find(What:=1, _
After:=Range("A9"), _
LookIn:=xlFormulas, _
LookAt:=xlWhole).Row
If lngRow > 10 Then
'wenn in nach Zeile 10 verschieben und löschen der Zeilen davor
Set ws = Worksheets("Schnittliste_Backup")
With Rows("10:" & lngRow - 1)
.Copy ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0)
.Delete
End With
'Formel löschen und Mappe speichern
Cells(1, 11).ClearContents
ThisWorkbook.Save
End If
'Prüfen ob Zahl 6 in Spalte A enthalten ist
ElseIf WorksheetFunction.CountIf(Range("A:A"), 6) > 0 Then
lngRow = Range("A:A").Find(What:=6, _
After:=Range("A9"), _
LookIn:=xlFormulas, _
LookAt:=xlWhole).Row
Set ws = Worksheets("Schnittliste_Backup")
'Verschieben und löschen der Zeilen 10 bis Ende der Liste
With Rows("10:" & lngRow)
.Copy ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0)
.Delete
End With
'Formel löschen und Mappe speichern
Range(strFormel).ClearContents
ThisWorkbook.Save
MsgBox "Die Liste ist fertig abgearbeitet"
Else
MsgBox "Es gibt keine Daten zum verarbeiten"
End If
ErrorHandler:
Application.EnableEvents = True
End Sub
