Schichtplan anlegen /z.Hd. Monika Weber/ aus ExcelVBA-Codebook.
RoDiMa
dies ist ein Original-Code aus o.g. Buch.
Möchte eigentlich hier direkt die Autorin Monika Weber ansprechen.:
In Cells(2, usw.) wird das Datum angelegt.
Wie bekomme ich in Cells 3 die Namen der Wochentage und evtl auch in einer
anderen die KW erstellt?
Kann mir das bitte jemand einfügen?
mfg
Rolf-Dieter
Sub Kalender_anlegen()
Dim Jahr As Integer
Dim Monat As Date, Mon As Byte
Dim i As Byte
Dim x As Integer
Workbooks.Add
Jahr = InputBox _
("Für welches Jahr wollen Sie einen Schichtplan erstellen?", _
"Jahresabfrage", _
IIf(Month(Date) > 9, Year(Date) + 1, Year(Date)))
Application.ScreenUpdating = False
'Monatsblätter anlegen
For Mon = 1 To 12
Monat = DateSerial(Jahr, Mon, 1)
Sheets.Add before:=Worksheets(Mon)
ActiveSheet.Name = Format(Monat, "mmm.yyyy")
[A1] = Format(Monat, "mmmm_yyyy")
[A2] = "Name, Vorname"
Columns(1).ColumnWidth = 13.86
'Datum eintragen
For i = 1 To 31
'Abfrage, ob Monat zu Ende
If Month(DateSerial(Jahr, Mon, i)) = Mon Then
Cells(2, i + 1) = DateSerial(Jahr, Mon, i)
Columns(i + 1).ColumnWidth = 2.43
Cells(2, i + 1).Orientation = 90
'Wochenende markieren
If WeekDay(Cells(2, i + 1)) = 1 Then _
Cells(2, i + 1).Interior.ColorIndex = 48
If WeekDay(Cells(2, i + 1)) = 7 Then _
Cells(2, i + 1).Interior.ColorIndex = 15
'Feiertage
If Right(Feiertag(Cells(2, i + 1)), 1) <> "*" _
And Feiertag(Cells(2, i + 1)) <> "" Then _
Cells(2, i + 1).Interior.ColorIndex = 48
If Right(Feiertag(Cells(2, i + 1)), 1) = "*" And _
Cells(2, i + 1).Interior.ColorIndex <> 48 Then _
Cells(2, i + 1).Interior.ColorIndex = 15
End If
Next i
Next Mon
'Überflüssige Tabellenblätter löschen
Application.DisplayAlerts = False
For x = Worksheets.Count To 13 Step -1
Worksheets(x).Delete
Next x
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Monika Weber
Um mich hier nicht mit fremden Federn zu schmücken:
Dieser Code stammt von Bert Körn.
Du könntest den Code beispielsweise wie folgt erweitern:
[...]
'Datum eintragen
For i = 1 To 31
'Abfrage, ob Monat zu Ende
If Month(DateSerial(Jahr, Mon, i)) = Mon Then
Cells(2, i + 1) = DateSerial(Jahr, Mon, i)
Columns(i + 1).ColumnWidth = 2.43
Cells(2, i + 1).Orientation = 90
' ERWEITERUNG
Cells(3, i + 1) = Cells(2, i + 1)
Cells(3, i + 1).NumberFormat = "ddd"
Cells(4, i + 1) = KALENDERWOCHE_DIN(Cells(2, i + 1))
[...]
Dazu benötigst Du jedoch eine weitere Function.
Füge die auch noch in das Modul ein:
Function KALENDERWOCHE_DIN(Datum As Date) As Integer
'von Christoph Kremer, Aachen
'Berechnt die KW nach DIN 1355
'Die DatePart()-Methode "versagt" unter anderem bei 29.12.2003/31.12.2007
Dim t&
t = DateSerial(Year(Datum + (8 - Weekday(Datum)) Mod 7 - 3), 1, 1)
KALENDERWOCHE_DIN = (Datum - t - 3 + (Weekday(t) + 1) Mod 7) \ 7 + 1
End Function
--
Ich hoffe, dass Dir das weiterhilft.
Es liebs Grüessli aus der Schweiz
Monika Weber
Fragen werden nur in Newsgroups kostenlos beantwortet.
------------------------------------------
Microsoft MVP für Excel
http://www.jumper.ch
http://excel.codebooks.de
"RoDiMa" <rolf-die...@t-online.de> schrieb im Newsbeitrag
news:#k36OAGsCHA.1676@TK2MSFTNGP10...
Bert Körn
Die Erweiterung von Monika funktioniert recht gut, bloß zerstört es in
dieser Form den Rest des Kalenders :-(
Da wäre ein Umbau des gesamten Codes notwendig.
Hier eine andere Variante, welche in der ersten Zeile die Kalenderwoche
zusätzlich einträgt.
Diese war ja noch frei :-)
Den Wochentag kann man im Datumsfeld zusätzlich darstellen, indem die Zellen
benutzerdefiniert formatiert werden.
' ERWEITERUNG Berti
Cells(2, i + 1).NumberFormat = "ddd, dd.mm.yy"
If Weekday(DateSerial(Jahr, Mon, i), vbMonday) = 1 Then _
Cells(1, i + 1) = KALENDERWOCHE_DIN(Cells(2, i + 1))
Einen guten Rutsch ins neue Jahr
Gruß
Berti
--------------------------------------------------------
Email: mailto:Be...@excelabc.de
Homepage: http://www.excelabc.de
Tipps und Tricks rund um Excel (mit Makros)
--------------------------------------------------------
"RoDiMa" <rolf-die...@t-online.de> schrieb im Newsbeitrag
news:#k36OAGsCHA.1676@TK2MSFTNGP10...
Hajo
da haben wir mal wieder das Problem mit dem Crossposting. Meine veränderung
am Code ist hier.
http://www.herber.de/forum/messages/197640.html
Gruß Hajo
"Bert Körn" <be...@excelabc.de> schrieb im Newsbeitrag
news:eCmlXKLsCHA.1808@TK2MSFTNGP09...
Bert Körn
Rolf-Dieter hat anscheinend die Seite 30 des Codebooks überblättert :-(
Wäre für ihn interessant zu lesen gewesen :-)
Gruß
Berti
--------------------------------------------------------
Email: mailto:Be...@excelabc.de
Homepage: http://www.excelabc.de
Tipps und Tricks rund um Excel (mit Makros)
--------------------------------------------------------
"Hajo" <hajoz...@web.de> schrieb im Newsbeitrag
news:up3JdSLsCHA.1816@TK2MSFTNGP10...