lulle schrieb am 02.12.2010 10:38:22:
Hallo,
leider funktioniert das nicht… am 01. wird eine Schicht ausgeben, danach nicht mehr…
Grüße, lulle
Ich habs getestet: So wie's jetzt ist funktioniert es bei mir einwandfrei.
Hat zwar vorher auch funktioniert, jetzt schließt es aber Flüchtigkeitsfehler aus.
Sub Schicht()
Dim StartSchicht As String
Dim dJahr As Integer
Dim dMonat As Integer
Dim dTag As Integer
Dim eTag As Integer
Dim LetzteZelle As String
Application.ScreenUpdating = False
dJahr = Application.InputBox(Prompt:="Welches Jahr?", Title:="Datum abfragen...", Type:=1)
dMonat = Application.InputBox(Prompt:="Welcher Monat?", Title:="Datum abfragen...", Type:=1)
StartSchicht = Application.InputBox(Prompt:="Welche Schicht am Monatsersten?", Title:="Schicht abfragen...", Type:=2)
Range("$A:$A").EntireColumn.ColumnWidth = 11
Range("$B$2:$AF$20").ClearContents
Range("$B$2:$AF$20").EntireColumn.ColumnWidth = 3
If dMonat < 12 Then
eTag = Day(DateSerial(dJahr, dMonat + 1, 0))
Else
eTag = Day(DateSerial(dJahr + 1, 1, 0))
End If
For dTag = 1 To eTag
Cells(6, dTag + 1) = Format(DateSerial(dJahr, dMonat, dTag), "ddd") & Chr(10) & Format(DateSerial(dJahr, dMonat, dTag), "dd")
If dTag + 1 = 2 Then
Cells(7, dTag + 1) = UCase(StartSchicht)
Else
Select Case Cells(7, dTag)
Case "C"
Cells(7, dTag + 1) = "B"
Case "B"
Cells(7, dTag + 1) = "A"
Case "A"
Cells(7, dTag + 1) = "D"
Case "D"
Cells(7, dTag + 1) = "C"
End Select
End If
Next dTag
Application.ScreenUpdating = True
End Sub
Severus |