AW: Code funktioniert nicht mehr
04.01.2007 09:13:56
Flux
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