AW: kalenderwochen dynamisch eintrage
28.08.2013 16:56:28
fcs
Hallo lupo,
hier dein Makro ergänzt um ein paar Eingabe-Prüfungen und die Erstellung des KW-Kalenders.
Der Kalender wird mit Tabellenformeln Erstellt, deren Ergebnisse dann durch ihre Werte ersetzt werden.
Zum Testen werden auch noch 1. und letzter Tag jeder KW ausgegeben.
Gruß
Franz
Sub kalender()
Dim startDate As Date, endDate As Date, recDate As Date, bisDate As Date
Dim wks As Worksheet, spalte As Long
Dim varEingabe As Variant, strFormel As String, strDat As String
Const Spalte_1 = 10 'Spalte J '1. Spalte des KW-Kalenders
Const msgTitel As String = "Erstellen KW-Kalender"
Set wks = ActiveSheet 'Tabellenblatt in dem der KW-Kalender erstellt werden soll
' Anfangsdatum:
Select Case Weekday(Date + 1, vbMonday)
Case Is > 5
recDate = Date + 3
Case Else
recDate = Date + 1
End Select
varEingabe = InputBox("Terminabfrage ab:" & Chr$(13) & _
"Datum muss im Format ""01.01.2004"" eingeben werden", msgTitel & " - Starttermin", _
Format(recDate, "dd.mm.yyyy"))
If varEingabe = "" Then
Exit Sub
ElseIf IsDate(varEingabe) Then
startDate = CDate(varEingabe)
Else
MsgBox "unzulässige Eingabe für Startdatum", , msgTitel
Exit Sub
End If
' Enddatum:
bisDate = startDate + 100
varEingabe = InputBox("Terminabfrage bis:" & Chr$(13) & _
"Datum muss im Format ""01.01.2004"" eingeben werden. " _
& "Das vorgeschlagene Datum ist 100 Tage nach dem Startdatum.", _
msgTitel & " - Endtermin", Format(bisDate, "dd.mm.yyyy"))
If varEingabe = "" Then
Exit Sub
ElseIf IsDate(varEingabe) Then
endDate = CDate(varEingabe)
If endDate = endDate
recDate = recDate + 7
spalte = spalte + 1
Loop
'Formeln einfügen und Formatieren
'Formelteil für Datum des 1. Tags der Kalenderwoche
strDat = "DATEVALUE(""" & startDate & """)+(COLUMN(RC)-COLUMN(RC" & Spalte_1 & "))*7 "
spalte = spalte
With .Range(.Cells(1, Spalte_1), .Cells(1, spalte - Spalte_1 + 1))
.Offset(0, -1).Range("A1") = "Monat"
'Formel für Monat des letzten Tags der KW
strFormel = "=TEXT(" & strDat & "+6,""MMMM"")"
.FormulaR1C1 = strFormel
.EntireColumn.ColumnWidth = 6
.Offset(1, -1).Range("A1") = "Kalenderwoche"
'Formel für KW (in Deutschland Montag = 1. Tag der KW) in Excel 2010 und neuer
'strFormel = "=WEEKNUM(" & strDat & ", 21)"
'Formel für KW (in Deutschland Montag = 1. Tag der KW) in allen Excel versionen
'Thanks to WWW.Excelformeln.de
strFormel = "=TRUNC((" & strDat & " - DATE(YEAR(" & strDat & " + 3-MOD(" _
& strDat & " -2,7)),1,MOD(" & strDat & " -2,7)-9))/7)"
.Offset(1, 0).NumberFormat = """KW ""00"
' Debug.Print strFormel
.Offset(1, 0).FormulaR1C1 = strFormel
'zum Testen - später wieder löschen
'GoTo weiter
.Offset(2, -1).Range("A1") = "Start"
With .Offset(2, 0)
'Formel für 1. Tag der KW
strFormel = "=" & strDat
.FormulaR1C1 = strFormel
.Font.Size = 6
.NumberFormat = "DDD DD.MM.YYYY"
End With
.Offset(3, -1).Range("A1") = "Ende"
With .Offset(3, 0)
.Font.Size = 6
.NumberFormat = "DDD DD.MM.YYYY"
'Formel für letzten Tag der KW
strFormel = "=" & strDat & " + 6"
.FormulaR1C1 = strFormel
End With
weiter:
'Formeln in Zeile 1 und 2 durch ihre Werte ersetzen
With .Resize(2, .Columns.Count)
.Value = .Value
End With
End With '.Range(.Cells(1, Spalte_1), .Cells(1, spalte))
'Monate löschen wenn identisch mit Monate vorher
For spalte = spalte To Spalte_1 Step -1
With .Cells(1, spalte)
If .Offset(0, -1).Value = .Value Then .ClearContents
End With
Next
End With ' wks
Application.ScreenUpdating = True
End Sub