Herbers Excel-Forum - das Archiv

Code funktioniert nicht mehr

Bild

Betrifft: Code funktioniert nicht mehr
von: Flux

Geschrieben am: 04.01.2007 08:18:09
Hallo,
letztes Jahr habe ich von euch einen Code bekommen, der bis dahin auch perfekt lief. Seit dem neuen Jahr aber zählt er nicht mehr hoch. Kann sich das mal jemand anschauen? Liegt scheinbar an der Länge der KW (nur eine Ziffer):
https://www.herber.de/forum/archiv/804to808/t806383.htm
Danke für eure Hilfe und ein frohes neues Jahr!
Bild

Betrifft: AW: Code funktioniert nicht mehr
von: Flux

Geschrieben am: 04.01.2007 09:13:56
Hallo,
so hier mal meine Version. Es ist wichtig, das diese nun wirklich zu 100% läuft. Könnt ihr vielleicht mal drüber schauen, das der Code auch alle Varianten abfängt? Es ist wichtig, das jetzt keine Fehler mehr auftreten dürfen:
Was würdet ihr verbessern?
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim LR&, TB, SP%, Neu$, Konst$, Jahr$, KW As Byte, tmp As Date, Lnr%, Zelle
Dim KWString As String
Set TB = Sheets("Tabelle1")
SP = 1 'SpalteA
LR = TB.Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
Set Zelle = TB.Cells(LR, SP)
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 Len(KW) = 1 Then
KWString = "0" + Trim(Str(KW))
ElseIf Len(KW) = 2 Then
Else
MsgBox "Fehler KW"
End If
If Zelle.Value = "" Then 'neu anlegen, wenn Zelle noch leer
Neu = Konst & Jahr & KWString & "1"
LR = 0
Else
'MsgBox Konst & Jahr & KWString
'MsgBox Mid(Sheets("Tabelle1").Cells(LR, SP).Value, 1, 5)
If Konst & Jahr & KWString <> Mid(Sheets("Tabelle1").Cells(LR, SP).Value, 1, 5) Then 'neue KW
Lnr = 1
Else 'gleiche KW
Lnr = Mid(Sheets("Tabelle1").Cells(LR, SP).Value, 6, Len(Sheets("Tabelle1").Cells(LR, SP).Value)) + 1
End If
Neu = Konst & Jahr & KWString & Lnr
End If
'Nr. in Zelle schreiben
TB.Cells(LR + 1, SP) = Neu
End Sub

 Bild