das nachfolgende UserForm erzeugt ausgehend von einem angebbaren Anfangsmonat, einem angebbaren Anfangsjahr und einer angebbaren Dauer einen Zeitplan, allerdings erfolgen die ausgegeben Daten im deutschen Format (Januar, Februar, ...). Meine Frage hierzu: Besteht die Moeglichkeit, die Monate auch im amerikansichen Format anzugeben (January, February, ...)?
Cells(6, i).NumberFormat = "mmm.yy"
Calender weeks from " & T_monat1 & " " & Jahr & " until " & _T_letzterMonat & " " & AktJahr
Ich habe die entsprechenden Bereiche fett markiert (ungefaehr in der Haelfte sowie im unteren Drittel des UserForm).
Vielen Dank fuer Hinweise und beste Gruesse
Carsten
Private Sub CommandButton1_Click() Dim Monat1, LetzterMonat, AktJahr, Jahr, Laenge, AktKw1, AktKw, i, j, k, AktMonat, AnzWoM, _ _ AnzWochen, LetzteZeile As Integer Dim tmp, datum, letzter, LetzterTag Dim T_monat1, T_letzterMonat As String 'Abfrage ob Zahlen eingegeben sind If IsNumeric(TextBox1.Text) = False Then MsgBox "Only odd numbers are valid!" & vbLf & "e.g. 11 for November", 16, "Error in _ field Month" TextBox1.Value = "" Exit Sub Else Monat1 = CInt(TextBox1.Text) End If If IsNumeric(TextBox2.Text) = False Then MsgBox "Only odd numbers (4 digit) are valid!" & vbLf & "e.g. 2014", 16, "Error in _ field Year" TextBox2.Value = "" Exit Sub Else Jahr = CInt(TextBox2.Text) End If If IsNumeric(TextBox3.Text) = False Then MsgBox "Only odd numbers are valid!" & vbLf & "e.g. 6 for 6 month", 16, "Error in field _ Duration" TextBox3.Value = "" Exit Sub Else Laenge = CInt(TextBox3.Text) - 1 End If datum = DateSerial(Jahr, Monat1, 1) tmp = DateSerial(Year(datum + (8 - Weekday(datum)) Mod 7 - 3), 1, 1) AktKw1 = ((datum - tmp - 3 + (Weekday(tmp) + 1) Mod 7)) \ 7 + 1 'Bereinigen der vorhanden Werte in Zeile 5,6 und 7 Range("J5", "FF300").Select With Selection .MergeCells = False .ClearContents .Borders(xlDiagonalDown).LineStyle = xlNone .Borders(xlDiagonalUp).LineStyle = xlNone .Borders(xlEdgeTop).LineStyle = xlNone .Borders(xlEdgeBottom).LineStyle = xlNone .Borders(xlEdgeRight).LineStyle = xlNone .Borders(xlInsideVertical).LineStyle = xlNone .Borders(xlInsideHorizontal).LineStyle = xlNone End With Range("J5", "FF7").Select Selection.Interior.ColorIndex = xlNone 'Hier wird separat die Zellenfarbe _ _ zurückgesetzt 'Letzte Kw bzw. letzter Tag If ((Monat1 + Laenge) Mod 12 = 0) Then 'Der fall, dass _ Dezember der letzter Monat ist, muss gesondert behandelt werden LetzterMonat = 12 AktJahr = Jahr + Int((Monat1 + Laenge) / 12) - 1 Else LetzterMonat = Monat1 + Laenge - 12 * Int((Monat1 + Laenge) / 12) AktJahr = Jahr + Int((Monat1 + Laenge) / 12) End If letzter = DateSerial(AktJahr, LetzterMonat + 1, 0) AktMonat = Monat1 i = 10 For j = 1 To Laenge + 1 datum = DateSerial(Jahr, AktMonat, 1) tmp = DateSerial(Year(datum + (8 - Weekday(datum)) Mod 7 - 3), 1, 1) AktKw1 = ((datum - tmp - 3 + (Weekday(tmp) + 1) Mod 7)) \ 7 + 1 If AktMonat Monat1 Then 'Erster monat wird aus folgender _ bedingung ausgeschlossen If Weekday(datum) vbMonday Then 'Wenn die der erste im Monat NICHT _ Montag ist, wird die aktuelle Kw um 1 hochgezählt If AktKw1 = 52 Or AktKw1 = 53 Then 'für den einen Fall, _ dass die Letzte angefangene Kw die letzte woche im jahr ist AktKw1 = 1 Else AktKw1 = AktKw1 + 1 End If End If End If 'Kalenderwoche des Letzten Tages im Monat finden LetzterTag = DateSerial(Jahr, AktMonat + 1, 0) tmp = DateSerial(Year(LetzterTag + (8 - Weekday(LetzterTag)) Mod 7 - 3), 1, 1) AktKw = ((LetzterTag - tmp - 3 + (Weekday(tmp) + 1) Mod 7)) \ 7 + 1 If AktKw = 1 Then 'Abfrage Sonderfall KW-Nr 1 _ noch im alten Jahr AnzWoM = 53 - AktKw1 Else AnzWoM = AktKw - AktKw1 'AnzWoM = Anzahl der Wochen des _ aktuellen Monats End If Range(Cells(6, i), Cells(6, i + AnzWoM)).Select Selection.Merge 'Zelle für Monat verbinden Selection.Borders(xlDiagonalDown).LineStyle = xlNone 'in diesem Abschnitt _ wird die eben verbundene Zelle mit einem Rahmen versehen Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With Selection.Interior.ColorIndex = 15 'farbe für diese Zelle Cells(6, i).NumberFormat = "mmm.yy" 'Monat in Zelle schreiben Cells(6, i).Value = datum For k = 0 To AnzWoM 'Felder mit KW Nummer ausfüllen If AktKw = 1 And k = AnzWoM Then Cells(7, i + k).Value = 1 Else Cells(7, i + k).Value = AktKw1 + k End If Cells(7, i + k).Select 'Rahmen für _ die Zellen Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With Selection.Interior.ColorIndex = 15 'farbe für _ diese Zelle Next k i = i + AnzWoM + 1 'i auf das Feld für die erste Woche _ des neuen monats beziehen AktMonat = AktMonat + 1 'Monat hochzählen Next j 'Um Titel und Kästchen zu formatieren wird i auf den letzten Wert (Wert für die Reihe) gebracht i = i - AnzWoM - 2 + k T_monat1 = MonthName(Monat1) T_letzterMonat = MonthName(LetzterMonat) AnzWochen = Int((letzter - datum) / 7) 'Titel Zelle formatieren Range(Cells(5, 10), Cells(5, i)).Select Selection.Merge 'Zelle für titel _ verbinden Selection.Borders(xlDiagonalDown).LineStyle = xlNone 'in diesem Abschnitt _ wird die eben verbundene Zelle mit einem Rahmen versehen Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With Selection.Interior.ColorIndex = 15 'farbe für diese Zelle 'Text in den Titel eintragen Cells(5, 10).Value = "Calender weeks from " & T_monat1 & " " & Jahr & " until " & _ T_letzterMonat & " " & AktJahr 'Suchen der letzten Zeile ("gekennzeichnet mit xx") LetzteZeile = 9 While Cells(LetzteZeile + 1, 1).Borders(xlEdgeRight).LineStyle xlNone 'Abfrage ob _ aktuelle Zeile rechten Rahmen hat LetzteZeile = LetzteZeile + 1 Wend 'Formatieren der Kennzeichnungskästchen Range(Cells(8, 10), Cells(LetzteZeile, i)).Select 'Rahmen zeichnen With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With Unload UserForm1 'Ende End Sub
Private Sub CommandButton2_Click()
Unload UserForm1
End Sub
Private Sub UserForm_Click()
End Sub