Lösungen zu Aufgabe2:


Die Frage als Worddokument findet Ihr hier: http://excelabc.de/excel/lernen/aufgabe2/aufgabe2.doc  
Diese stammt von  Peter Haserodt

Eintragen könnt ihr Eure Lösung(en) in ein moderiertes Gästebuch
Das bedeutet: Deine Lösung wird erst zur Eröffnung eingeblendet.
Vorher sehen die anderen Deine Lösung nicht.

5. Lösung von Monika: 14.12.2001, 08:50
Kommentar:  

Option Explicit
Sub Wochentage_erzeugen()

' Der Code entstand mit lieber Unterstützung
' meines Lehrers Berti :-)
' (Er hat mir ein kleines bisschen weitergeholfen - Danke Berti!)
' Also ich fand diese Aufgabe nicht einfach!
' Ich hab ein bisschen gemogelt bei der Formel - leider wird
' das wahrscheinlich unter der Version 97 nicht laufen :-(

Dim WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet
Dim WS4 As Worksheet, WS5 As Worksheet, WS6 As Worksheet
Dim WS7 As Worksheet, WB As Workbook
Dim x, i
Dim t As Long
Dim d As Date

' Neue Mappe erzeugen
Workbooks.Add

' Checken, wieviele Mappen bereits vorhanden sind
' und dann die fehlenden hinzufügen, bis es 7 sind.
i = Sheets.Count
x = 7 - i
For i = 1 To x
Worksheets.Add
Next i

Set WB = ActiveWorkbook
Set WS1 = WB.Worksheets(1)
Set WS2 = WB.Worksheets(2)
Set WS3 = WB.Worksheets(3)
Set WS4 = WB.Worksheets(4)
Set WS5 = WB.Worksheets(5)
Set WS6 = WB.Worksheets(6)
Set WS7 = WB.Worksheets(7)

WS1.Name = "Montag"
WS2.Name = "Dienstag"
WS3.Name = "Mittwoch"
WS4.Name = "Donnerstag"
WS5.Name = "Freitag"
WS6.Name = "Samstag"
WS7.Name = "Sonntag"

' Gleiche Tabellen aufbauen (Montag - Freitag)
For x = 1 To 5
With Worksheets(x)
.PageSetup.LeftHeader = "&A"
.PageSetup.Orientation = xlLandscape
.[A1].FormulaR1C1 = "=WEEKNUM(TODAY(),1)"
With .[B2:F23]
.Font.Bold = True
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
End With
End With
Next x

' Freitag
With WS5
.[B2:F23].Interior.ColorIndex = 1
.[B2:F23].Font.ColorIndex = 2
End With

' Samstag
With WS6
.PageSetup.LeftHeader = "&A"
.[A1].FormulaR1C1 = "=WEEKNUM(TODAY(),1)"
With .[B2:F23]
.Font.Bold = True
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
End With
End With

' Sonntag
With WS7
.Cells(1, 4) = "Sonntag"
.PageSetup.LeftHeader = "&A"
.[A1].FormulaR1C1 = "=WEEKNUM(TODAY(),1)"
With .[B2:F23]
.Font.Bold = True
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
End With
End With

End Sub


'Also ein bisschen hab ich der Monika schon geholfen, 
'aber den endgültigen Code sehe ich auch erst jetzt.  :-) 
'Sie hat die Performance noch ganz schön gesteigert.


4. Lösung von Thomas Ramel : 14.12.2001, 07:29
Kommentar:  
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
Public Sub Wochentage____Thomas()
' Makro geschrieben am 11.12.2001 von T.Ramel
' Erzeugt eine neue Arbeitsmappe, mit 7 Sheets (Montag...Sonntag)
' und formatiert diese nach Vorgaben
Dim iAnfangsZeit As Long
Application.ScreenUpdating = False
iAnfangsZeit = GetTickCount
'*** Hier den eigenen Code beginnen
Dim i As Integer
Workbooks.Add
Sheets.Add Count:=7 - Worksheets.Count
For i = 1 To Worksheets.Count
With Worksheets(i)
.Name = Format(i + 1, "dddd")
.PageSetup.LeftHeader = "&A"
.[A1] = Format(Date, "ww", vbMonday, vbFirstFourDays)
End With
Select Case i
Case 1 To 4
Worksheets(i).PageSetup.Orientation = xlLandscape
With Worksheets(i).Range("B2:F23")
.Font.Bold = True
.Borders(xlEdgeLeft).Weight = xlThick
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlEdgeRight).Weight = xlThick
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideHorizontal).Weight = xlThick
End With
Case 5
With Worksheets(i)
.PageSetup.Orientation = xlLandscape
.Range("B2:F23").Interior.ColorIndex = 1
.Range("B2:F23").Font.ColorIndex = 2
End With
With Worksheets(i).Range("B2:F23")
.Font.Bold = True
.Borders(xlEdgeLeft).Weight = xlThick
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlEdgeRight).Weight = xlThick
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideHorizontal).Weight = xlThick
End With
Case 6
With Worksheets(i).Cells
.Borders(xlEdgeLeft).Weight = xlThick
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlEdgeRight).Weight = xlThick
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideHorizontal).Weight = xlThick
End With
Case 7
Worksheets(i).[D1] = Worksheets(i).Name
With Worksheets(i).Range("B2:F23")
.Font.Bold = True
.Borders(xlEdgeLeft).Weight = xlThick
.Borders(xlEdgeTop).Weight = xlThick
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlEdgeRight).Weight = xlThick
.Borders(xlInsideVertical).Weight = xlThick
.Borders(xlInsideHorizontal).Weight = xlThick
End With
End Select
Next i
'Workbooks("Wochentage_Erzeugen.xls").Activate
'Einziges Activate, da bei Workbooks.Add der Focus zur neuen Arbeitsmappe wechselt
'*** Hier den eigenen Code abschliessen
Debug.Print GetTickCount - iAnfangsZeit
'Workbooks("Wochentage_Erzeugen.xls").Sheets("Tabelle1").[D1] = (GetTickCount - iAnfangsZeit) / 1000
Application.ScreenUpdating = True
End Sub

3. Lösung von Marcus: 12.12.2001, 15:53
Kommentar:  
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
'VBA-Funktion zur Berechnung der Kalenderwoche nach DIN
Function KWoche(d As Date)
Dim t As Long
t = DateSerial(Year(d + (8 - Weekday(d)) Mod 7 - 3), 1, 1)
KWoche = ((d - t - 3 + (Weekday(t) + 1) Mod 7)) \ 7 + 1
End Function

Sub Aufgabe2_Marcus1()
Dim Number_of_Sheets As Byte
Dim i As Byte
Dim xRange
Dim iAnfangsZeit As Long
Dim WB As String
Const Bereich As String = "B2:F23"
'Start
iAnfangsZeit = GetTickCount
Application.ScreenUpdating = False
Application.EnableEvents = False
'Neue Arbeitsmappe mit 7 Tabellenblättern erzeugen:
Number_of_Sheets = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 7
WB = Workbooks.Add.Name
Application.SheetsInNewWorkbook = Number_of_Sheets
With Workbooks(WB)
'Tabellenblätter benennen (dabei Index statt Name verwenden,
'falls landessprachliche Tabellenbezeichnung anders z.B.:
'statt Tabelle1 -> Sheet1):
.Sheets(1).Name = "Montag"
.Sheets(2).Name = "Dienstag"
.Sheets(3).Name = "Mittwoch"
.Sheets(4).Name = "Donnerstag"
.Sheets(5).Name = "Freitag"
.Sheets(6).Name = "Samstag"
.Sheets(7).Name = "Sonntag"
'Kopfzeile einrichten:
'Mit For-Schleife, weil sich alle Blätter nicht gleichzeitig
'ansprechen lassen...(zumindest weiß ich nicht, wie...)
For i = 1 To 7
.Sheets(i).PageSetup.LeftHeader = "&A"
Next i
'Querformat für Mo-Fr einrichten:
'Mit For-Schleife, weil sich alle Blätter nicht gleichzeitig
'ansprechen lassen...(zumindest weiß ich nicht, wie...)
For i = 1 To 5
.Sheets(i).PageSetup.Orientation = xlLandscape
Next i
'Bereich selektieren:
.Sheets(Array(1, 2, 3, 4, 5, 6, 7)).Select
.ActiveSheet.Range(Bereich).Select
'Bereich formatieren:
'Zwischen links und rechts kommt oben und unten,
'daher habe ich eine For-Schleife genommen => etwas weniger Code...
Set xRange = Selection
xRange.Font.Bold = True
For i = xlEdgeLeft To xlEdgeRight
xRange.Borders(i).LineStyle = xlContinuous
xRange.Borders(i).Weight = xlThick
Next i
'Freitag ergänzend formatieren:
'einzelne Blätter lassen sich direkt ansprechen...
.Sheets("Freitag").Range(Bereich).Font.ColorIndex = 2
.Sheets("Freitag").Range(Bereich).Interior.ColorIndex = 1
'Sonntag einrichten:
'einzelne Blätter lassen sich direkt ansprechen...
.Sheets("Sonntag").Range("D2") = "Sonntag"
'Samstag ergänzend formatieren:
'einzelne Blätter lassen sich direkt ansprechen...
For i = xlInsideVertical To xlInsideHorizontal
.Sheets("Samstag").Range(Bereich).Borders(i).LineStyle = xlContinuous
.Sheets("Samstag").Range(Bereich).Borders(i).Weight = xlThick
Next i
'Kalenderwoche einfügen:
.Sheets(Array(1, 2, 3, 4, 5, 6, 7)).Select
.ActiveSheet.Range("A1").Select
'entweder die VB-Function oder die Formel direkt:
'Selection.FormulaR1C1 = "=Wochentage_erzeugen.xls!Kwoche(TODAY())"
Selection = "=rounddown(" & _
" (today() - (date(year(today() + 8 - mod(weekday(today()), 7) - 3),1,1)) - 3" & _
" + mod(weekday((date(year(today() + 8 - mod(weekday(today()), 7) - 3),1,1))) + 1, 7))" & _
" / 7, 0) + 1"
'Tabellenblatt Montag anwählen:
.Sheets("Montag").Select
End With
'Ausgabe der 1000stel Sekunden im Direktfenster
Debug.Print GetTickCount - iAnfangsZeit
End Sub

2. Lösung von Berti: 11.12.2001, 00:22
Kommentar:  
Option Explicit
Sub Wochentage_erzeugen_Berti1()
Dim WB As Workbook
Dim WS As Worksheet
Dim x, alt
'Einstellung neue Blätter ändern
alt = Application.SheetsInNewWorkbook 'alt auslesen
Application.SheetsInNewWorkbook = 7 'verändern
Workbooks.Add
Application.SheetsInNewWorkbook = alt 'zurücksetzen
Set WB = ActiveWorkbook

For x = 1 To 7
Set WS = WB.Worksheets(x)
With WS
.Name = Format(x + 1, "DDDD")
.PageSetup.LeftHeader = Format(x + 1, "DDDD")
If x < 6 Then .PageSetup.Orientation = xlLandscape
If x = 7 Then .[D1] = "Sonntag"
.[A1] = "KW " & DatePart("ww", Date, vbMonday, vbFirstFourDays)
'sonst sieht das Tabellenblatt so leer aus ;-)
.[a2] = Format(Date + x - Weekday(Date, 2), "DD.MM.YYYY")
End With
With WS.[B2:F23]
If x = 6 Then .Borders.Weight = xlThin
.Font.Bold = True
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
If x = 5 Then .Interior.ColorIndex = 1
If x = 5 Then .Font.ColorIndex = 2
End With
Next x
End Sub

1. Lösung von Hajo: 10.12.2001, 19:49
Kommentar:  
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
Sub Aufgabe2___Hajo()
Dim iAnfangsZeit As Long
Dim I As Integer
iAnfangsZeit = GetTickCount
Application.ScreenUpdating = False
Workbooks.Add
With ActiveSheet
.Name = "Montag"
.PageSetup.LeftHeader = "&A"
' Kalenderwoche
' Warum muß es so eine komlizierte Formel sein Erklärung von WF
' Die Funktion KALENDERWOCHE rechnet falsch oder sagen wir es gnädiger:
' nach amerikanischem Standard. Der 01.01.2000 z.B. ist laut DIN die
' 52. KW des Jahres 1999; - in den USA die erste im Jahre 2000.
' Das hab ich mir irgendwann mal kopiert:
' Erst 1976 wurde der Wochenbeginn auf Montag festgelegt. Die erste Woche
' des Jahres ist definiert als die Woche,in die mindestens 4 Tage fallen.
' Beides = DIN 1355 (1974) Entspricht der internationalen Norm ISO 8601 (1988);
' -übernommen von der EU ! als EN 28601 (1992) und in Deutschland als DIN EN 28601 (1993) umgesetzt.
' Erklärung von WF
' von WF
.Range("A1").FormulaR1C1 = "=TRUNC((TODAY()-WEEKDAY(TODAY(),2)-DATE(YEAR(TODAY()+4-WEEKDAY(TODAY(),2)),1,-10))/7)&"".KW"""
With .Range("B2:F23")
' Schrift fett
.Font.Bold = True
' Rahmen ganz links
.Borders(xlEdgeLeft).Weight = xlThick
' Rahmen Oben
.Borders(xlEdgeTop).Weight = xlThick
' Rahmen unten
.Borders(xlEdgeBottom).Weight = xlThick
' Rahmen ganz rechts
.Borders(xlEdgeRight).Weight = xlThick
End With
End With
' restliche Wochentage anlegen
For I = 1 To 6
Sheets("Montag").Copy After:=Sheets(Worksheets.Count)
' jetz aber nicht fragen warum ,6 nur durch Testung
ActiveSheet.Name = Format(Weekday(I, 6), "dddd")
Next I
With Worksheets("Freitag").Range("B2:F23")
.Interior.ColorIndex = 1
'        .Pattern = xlSolid
.Font.ColorIndex = 2
End With
With Worksheets("Samstag")
' Rahmen zwischen den Spalten
' Rahmen zwischen den Zeilen
With .Range("B2:F23")
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
End With
End With
Worksheets("Sonntag").Range("D1") = "Sonntag"
For I = 1 To 5
Worksheets(I).PageSetup.Orientation = xlLandscape
Next I
'&n! bsp; 
Application.ScreenUpdating = True
Debug.Print GetTickCount - iAnfangsZeit
End Sub


Diese Seite ist Teil eines Framesets von Excelabc.de.
Falls Sie auf der linken Seite kein Navigationsframe sehen, klicken Sie bitte auf das Logo.

letzte Aktualisierung dieser Seite am Montag, 29. November 2004 06:59