Option Explicit
'SCHALTFLAECHE EINFUEGEN
'a) Zeile oberhalb der Überschrift auf Offenen Punkte einfuegen
'b) In einer Zelle dieser zeile Command-Button einfügen
'c) Command-Button mit rechter Maustaste
' -> Steuerelement formatieren
' -> Reiter Eigenschaften
' -> von Zellposition ind -größe abhängig setzen
'd) Command-Button mit rechter Maustaste
' -> Eigenschaften
'd1) Caption entsprechenden text eingeben z.B. Makro x
'd2) TakeFocusOnClick auf false setzen
'e) Command-Button mit rechter Maustaste
' -> Code anzeigen
'folgenden Code eingeben:
'Private Sub CommandButton1_Click()
' Call OffenePunkteErledigtVerschieben
'End Sub
'f) Entwurfsmodus ausschalten und ausprobieren
Sub OffenePunkteErledigtVerschieben()
Const cOP_BltName = Offenen Punkte
Const cOP_Z_ERSTEWERTEZEILE = 2
Const cOP_SPK = 11
Const cEA_BltName = Erledigte Aufgaben
Dim wb As Workbook, wsop As Worksheet, wsea As Worksheet
Set wb = ActiveWorkbook
On Error Resume Next
Set wsop = wb.Worksheets(cOP_BltName)
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
MsgBox Blatt & cOP_BltName & nicht erreichbar.
GoTo AUFRAEUMEN
End If
Set wsea = wb.Worksheets(cEA_BltName)
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
MsgBox Blatt & cEA_BltName & nicht erreichbar.
GoTo AUFRAEUMEN
End If
On Error GoTo 0
Call ErledigteSaetzeUebertragen(wsop, cOP_SPK, cOP_Z_ERSTEWERTEZEILE, wsea)
AUFRAEUMEN:
Set wb = Nothing: Set wsop = Nothing: Set wsea = Nothing
End Sub
'***********************************************************
Private Function ErledigteSaetzeUebertragen(wsop As Worksheet, sp As Long, zanf As Long, _
wsea As Worksheet)
Dim lOPRows As Long, lOPCols As Long, lEARows As Long, x As Long
->jeweils letzte Zeile bestimmen
lOPRows = wsop.Cells(wsop.Rows.Count, sp).End(xlUp).Row
lEARows = wsea.Cells(wsea.Rows.Count, sp).End(xlUp).Row
For x = lOPRows To zanf Step -1
If IsDate(wsop.Cells(x, sp).Value) Then
lOPCols = wsop.Cells(x, wsop.Columns.Count).End(xlToLeft).Column
lEARows = lEARows + 1
wsop.Range(wsop.Cells(x, 1), wsop.Cells(x, lOPCols)).Copy _
Destination:=wsea.Range(wsea.Cells(lEARows, 1), wsea.Cells(lEARows, lOPCols))
wsop.Rows(x).Delete
End If
Next
End Function
