AW: laufende Nummerierung und korrekte Archivierung
14.10.2011 22:05:43
fcs
Hallo El_presidente1
mit Formeln kannst du die fortlaufende Nummer und das Eintragsdatum nicht verwalten.Du musst jeweils feste Werte in Spalte A und B eintragen.
Den letzten Wert des fortlaufenden Zähler kannst du unter einem Namen speichern. Alternativ könntest du auch eine Zelle in einem Tabellenblatt verwenden, um den letzten Wert des Zählers zu speichern.
Füge in deiner Datei den Namen "Zaehler" ein. Unter bezieht sich auf trägst du die Formel =0 ein.
Mit den nachfolgenden Anpassungen in deinem Makro1 wird dann jeweils der Zähler-Wert um 1 erhöht und zusammen mit dem heutigen Datum für ein neues Item eingetragen.
Update funktioniert dann auch. Ein Problem gibt es jedoch, wenn alle Items "done" sein können. Dann werden alle Zeilen übertragen und gelöscht. Danach fehlt dann eine Musterzeile für ein neues Item. Falls das vorkommen kann, dann muss du ggf. deine Update-Makros in diese Richtung korrigieren. Irgendwie hast du eine extrem aufwendige Form (mit all den Konstanten) im Code für das Kopieren gewählt. Da hatte ich jetzt keinen Nerv, die passende Position für eine entsprechende Prüfung zu suchen. Nachfolgend auch noch mein Vorschlag das Update-Makro.
Gruß
Franz
Sub Makro1()
With ActiveCell
If .Row > 7 Then
.Offset(-1, 0).EntireRow.Copy
.EntireRow.Insert Shift:=xlDown
Application.CutCopyMode = False
On Error Resume Next
.Offset(-1, 0).EntireRow.SpecialCells(xlCellTypeConstants).ClearContents
'Datum in Spalte B der neuen Zeile eintragen
ActiveSheet.Cells(.Row - 1, 2) = Date
'Zähler-Wert des Names um 1 erhöhen
With Application.Names("Zaehler")
.RefersTo = "=" & Val(Mid(.Value, 2)) + 1
End With
'Neuen Zähler-Wert des Names in Spalte A der neuen Zeile eintragen
ActiveSheet.Cells(.Row - 1, 1) = Val(Mid(Application.Names("Zaehler").Value, 2))
Else
If .Row = 7 And IsEmpty(ActiveSheet.Cells(.Row, 1)) Then
'Datum in Spalte B der Zeile 7 eintragen
ActiveSheet.Cells(.Row, 2) = Date
'Zähler-Wert des Names um 1 erhöhen
With Application.Names("Zaehler")
.RefersTo = "=" & Val(Mid(.Value, 2)) + 1
End With
'Neuen Zähler-Wert des Names in Spalte A der Zeile 7 eintragen
ActiveSheet.Cells(.Row, 1) = Val(Mid(Application.Names("Zaehler").Value, 2))
Else
MsgBox "Bitte eine Zeile unterhalb Zeile 7 wählen", vbInformation, _
"neues open-item eintragen"
End If
End If
End With
End Sub
Sub Update()
Dim Zeile As Long, ZeileArchiv As Long, ZeileL As Long, iCount As Long
With Worksheets("open items")
ZeileL = .Cells(.Rows.Count, 1).End(xlUp).Row
If ZeileL 7 Then
If Application.WorksheetFunction.CountBlank(.Range(.Cells(8, 1), _
.Cells(ZeileL, 1))) > 0 Then
If ZeileL = 8 Then
.Rows(8).Delete
Else
.Range(.Cells(8, 1), .Cells(ZeileL, 1)).SpecialCells(xlCellTypeBlanks).EntireRow. _
Delete
End If
End If
'leere Zeile 7 löschen, wenn noch andere Zeilen vorhanden sind
ZeileL = .Cells(.Rows.Count, 1).End(xlUp).Row
If ZeileL > 7 And IsEmpty(.Cells(7, 1)) Then .Rows(7).Delete
End If
End With
MsgBox "Es wurden " & iCount & " erledigte Zeilen ins Archiv übertragen", vbInformation, _
"Done-Items ins Archiv"
End Sub