Hochzähler bei neuer KW zurücksetzen

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim Neu$, Konst$, Jahr$, KW As Byte, tmp As Date, Lnr%, Zelle Set Zelle = Sheets("Tabelle1").Range("A1") 'Rechnungsnummer steht in A1 Jahr = Format(Date, "YY") Konst = "M" 'aktuelle KW ermitteln tmp = DateSerial(Year(Date + (8 - Weekday(Date)) Mod 7 - 3), 1, 1) KW = ((Date - tmp - 3 + (Weekday(tmp) + 1) Mod 7)) \ 7 + 1 If Zelle.Value = "" Then 'neu anlegen Neu = Konst & Jahr & KW & "1" Else If KW > Mid(Zelle, 4, 2) Then 'neue KW Lnr = 1 Else 'gleiche KW Lnr = Mid(Zelle, 6) + 1 End If Neu = Konst & Jahr & KW & Lnr End If 'Nr. in Zelle schreiben Sheets("Tabelle1").Range("A1") = Neu End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
ich hatte dir nochmal ein Update veröffentlicht, wo ein Fehler beim Jahreswechsel behoben wurde... die solltest du nehmen.
unabhängig davon wird das Rücksetzen aber bereits gemacht.

Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim Neu$, Konst$, Jahr$, KW As Byte, tmp As Date, Lnr%, Zelle
    Set Zelle = Sheets("Tabelle1").Range("A1") 'Rechnungsnummer steht in A1
    Jahr = Format(Date, "YY")
    Konst = "M"
    'aktuelle KW ermitteln
        tmp = DateSerial(Year(Date + (8 - Weekday(Date)) Mod 7 - 3), 1, 1)
        KW = ((Date - tmp - 3 + (Weekday(tmp) + 1) Mod 7)) \ 7 + 1
    '
    If Zelle.Value = "" Then 'neu anlegen, wenn Zelle noch leer
        Neu = Konst & Jahr & KW & "1"
    Else
        '**************
        'Wert aus Zelle wird geprüft, ob die enthaltene Woche Gleich der aktuellen Woche ist
        'es wird das Jahr mitbeachtet'
        'Ist Jahr und Woche ungleich aktuellemJahr und Woche, wird Laufende Nr. auf 1 gesetzt
        'Beispiel:
        '0638 ist ungleich 0639 Folge Zähler beginnt bei 1
        If Jahr & KW <> Mid(Zelle, 2, 4) Then 'neue KW
            Lnr = 1
        '*********************
        'Ist der gelesene Wert gleich Jahr und aktuelle Woche
        'wird der Zähler um eins erhöht'
        '******************
        Else 'gleiche KW
            Lnr = Mid(Zelle, 6) + 1
        End If
        '
        Neu = Konst & Jahr & KW & Lnr
    End If

    'Nr. in Zelle schreiben
    Sheets("Tabelle1").Range("A1") = Neu

End Sub

Gruß UweD
(Rückmeldung wäre schön)

Hallo Uwe!
Ich habe nun noch einige Änderungen an dem Makro vorgenommen um es auf unsre Tabelle abzustimmen.
Unter anderem auch, das die Nummer nicht bei jedem Sichern geändert wird.
Die Nummer müsste sich erst dann ändern, wenn sich die zweite Nummer auf die sie sich bezieht, ändert.
Wenn sich bei zweiten Nummer nichts ändert, dann soll auch die Numer nicht geändert werden.
Verständlich?
Nur gibt es hier Probleme mit der Dimension, da ein Stapelfehler auftritt.
Wie kann ich dies verhindern?
Hier nochmal mein mein/dein Makro:


Private Sub Worksheet_Change(ByVal SaveAsUI As Range)
Dim LR&, TB, SP%, Neu$, Konst$, Jahr$, KW As Byte, tmp As Date, Lnr%, Zelle
Set TB = Sheets("Datenbank")
SP = 10 'SpalteA
LR = TB.Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
Set Zelle = TB.Cells(LR, SP)
'If [Eingabemaske!G30] = J + Zelle Then
'Sheets("Eingabemaske").Range("A1").Value = "keine überschreibung"
'Else
Jahr = Format(Date, "YY")
Konst = "M"
'aktuelle KW ermitteln
tmp = DateSerial(Year(Date + (8 - Weekday(Date)) Mod 7 - 3), 1, 1)
KW = ((Date - tmp - 3 + (Weekday(tmp) + 1) Mod 7)) \ 7 + 1
If Zelle.Value = "" Then 'neu anlegen, wenn Zelle noch leer
Neu = Konst & Jahr & KW & "1"
LR = 0
Else
If Jahr & KW <> Mid(Zelle, 2, 4) Then 'neue KW
Lnr = 1
Else 'gleiche KW
Lnr = Mid(Zelle, 6) + 1
End If
Neu = Konst & Jahr & KW & Lnr
End If
'Nr. in Zelle schreiben
'Worksheets("Eingabemaske").Activate
'Sheets ("Eingabemaske")
Set TB = Sheets("Eingabemaske")
TB.Cells(30, 7) = Neu
'End If
End Sub

Private Sub Worksheet_Change(ByVal SaveAsUI As Range) Dim LR&, TB, SP%, Neu$, Konst$, Jahr$, KW As Byte, tmp As Date, Lnr%, Zelle Set TB = Sheets("Datenbank") SP = 10 'SpalteA LR = TB.Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte Set Zelle = TB.Cells(LR, SP) 'If [Eingabemaske!G30] = J + Zelle Then 'Sheets("Eingabemaske").Range("A1").Value = "keine überschreibung" 'Else Jahr = Format(Date, "YY") Konst = "M" 'aktuelle KW ermitteln tmp = DateSerial(Year(Date + (8 - Weekday(Date)) Mod 7 - 3), 1, 1) KW = ((Date - tmp - 3 + (Weekday(tmp) + 1) Mod 7)) \ 7 + 1 If Zelle.Value = "" Then 'neu anlegen, wenn Zelle noch leer Neu = Konst & Jahr & KW & "1" LR = 0 Else If Jahr & KW <> Mid(Zelle, 2, 4) Then 'neue KW Lnr = 1 Else 'gleiche KW Lnr = Mid(Zelle, 6) + 1 End If Neu = Konst & Jahr & KW & Lnr End If 'Nr. in Zelle schreiben 'Worksheets("Eingabemaske").Activate 'Sheets ("Eingabemaske") Set TB = Sheets("Eingabemaske") TB.Cells(30, 7) = Neu 'End If End Sub

Beliebteste Forumthreads (12 Monate)

Hochzähler bei neuer KW zurücksetzen

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Hochzähler bei neuer KW zurücksetzen

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread