Excel Makro

Option Explicit

Sub ZeileBearneiten()

'*** Es wird zunächst geprüft, ob eine Zeile selektiert ist (oder Zellen einer Zeile).
'*** Sind mehrere Zeilen selektiert, wird eine entsprechende Meldung ausgegeben und der Makro beendet.
'*** Es wird weiterhin geprüft, ob die Zeilenr gleich der Zielzeilennummer ist.
'*** Ist das der Fall, wird eine entsprechende Meldung ausgegeben und der Makro beendet.
'***
'*** Dann wird geprüft, ob diese Zeile in Spalte A den Wert 6 enthält.
'*** Ist das nicht der Fall ist die Bearbeitung beendet.
'*** Andernfalls wird die Zeile an Zeile 8 verschoben.
'*** In diesem Fall wird auch geprüft, ob Zeile 10 in Spalte A der Wert 0 enthält.
'*** Wenn ja, wird geprüft ob das Blatt->gefertigt' vorhanden ist.
'*** Ist es nicht vorhanden, wird es angelegt (nach dem aktuellen Blatt).
'*** Auf diese Blatt wird die Zeile 10 an Zeile 2 eingefügt und im Ursprungsblatt gelöscht.
'*** Zum Schluß könnte man speichern (ist auskommentiert)
 
 Const c_SP_PRUEFE_WERT = 1
 Const c_Z_VERSCH = 8
 Const c_Z_VERSCH_WERT = 6
 Const c_Z_LOE = 10
 Const c_Z_LOE_WERT = 0

 Const c_BLT_NAME_GEFERTIGT = gefertigt
 Const c_GEFERTIGT_Z_EINFUEGEN = 2

 Dim wb As Workbook, ws As Worksheet, wsx As Worksheet, wsz As Worksheet
 Dim x As Long, lZeileAktuell As Long
 
->prüfen, ob im aktuellen Blatt nur Zellen einer Zeile selektiert sind
 If Selection.Rows.Count <> 1 Then MsgBox Mehr als eine Zeile selektiert: GoTo AUFRAEUMEN
->selektierte Zeile merken
 lZeileAktuell = Selection.Row
 
->aktives Blatt setzen
 Set ws = ActiveSheet
 
->prüfen, ob Zelle in Spalte A den Wert 6 enthält
 If ws.Cells(lZeileAktuell, c_SP_PRUEFE_WERT).Value <> c_Z_VERSCH_WERT Then GoTo AUFRAEUMEN
  
->Bildschirm-Update anhalten
 Application.ScreenUpdating = False
 
->Zeile an Zeile 8 verschieben
 ws.Rows(c_Z_VERSCH).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
 If lZeileAktuell >= c_Z_VERSCH Then lZeileAktuell = lZeileAktuell + 1
 ws.Rows(lZeileAktuell).EntireRow.Cut Destination:=ws.Cells(c_Z_VERSCH, 1)
 ws.Rows(lZeileAktuell).Delete Shift:=xlUp
 Application.CutCopyMode = False

->Prüfen, ob in Zeile 10 die Zelle in Spalte A den Wert 0 hat. Wenn nein, Bearbeitungsende
 If ws.Cells(c_Z_LOE, c_SP_PRUEFE_WERT).Value <> c_Z_LOE_WERT Then GoTo AUFRAEUMEN
 
->Blatt->Geferitg' setzen
 Set wb = ws.Parent
 For x = 1 To wb.Worksheets.Count
  If LCase(c_BLT_NAME_GEFERTIGT) = LCase(wb.Worksheets(x).Name) Then Set wsz = wb.Worksheets(x)
 Next
->Blatt nicht vorhanden -> erzeugen
 If wsz Is Nothing Then Set wsz = wb.Worksheets.Add(After:=ws): wsz.Name = c_BLT_NAME_GEFERTIGT
  
->Zeile 10 ausschneiden und auf Blatt->gefertigt' in Zeile 2 einfügen
 wsz.Rows(c_GEFERTIGT_Z_EINFUEGEN).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
 ws.Rows(c_Z_LOE).EntireRow.Cut Destination:=wsz.Cells(c_GEFERTIGT_Z_EINFUEGEN, 1)
 ws.Rows(c_Z_LOE).Delete Shift:=xlUp
 Application.CutCopyMode = False
  
->ursprüngliches Blatt in den Vordergrund
 ws.Activate
 
->Bildschirm-Update fortsezen
 Application.ScreenUpdating = True
 
->hier könnte man speichern (ist auskommentiert)
->wb.save
  
AUFRAEUMEN:
 Set wb = Nothing: Set ws = Nothing: Set wsz = Nothing
End Sub