Fehler - Geburtstage 366 Tage warum nicht länger?
28.06.2004 10:27:07
Andy
habe in einem fortlaufenden Kalender (Heute - 90 und Heute + 366;
also von Zeile 2 bis Zeile 457) Geburtstage als Kommentare ent-
halten. Das funktioniert sehr gut und sieht so aus:
=================================================================
Sub Notiz_Geburtstag()
Dim Alter As Byte
Dim WS1 As Worksheet, WS2 As Worksheet
Dim iZeile As Long, iiZeile As Long
Application.ScreenUpdating = False
Set WS1 = Worksheets("Dienstplan")
Set WS2 = Worksheets("Geburtstage")
'Selection.ShapeRange.ScaleWidth 1.74, msoFalse, msoScaleFromTopLeft
PW_entf
For iZeile = 1 To WS1.Range("A65536").End(xlUp).Row
If Not WS1.Cells(iZeile, 1).Comment Is Nothing Then WS1.Cells(iZeile, 1).ClearComments
Next iZeile
For iZeile = 4 To WS2.Range("B65536").End(xlUp).Row
For iiZeile = 2 To WS1.Range("A65536").End(xlUp).Row
If Day(WS1.Cells(iiZeile, 1)) = Day(WS2.Cells(iZeile, 3)) And _
Month(WS1.Cells(iiZeile, 1)) = Month(WS2.Cells(iZeile, 3)) Then Exit For
Next iiZeile
With WS1.Cells(iiZeile, 1)
Alter = Year(WS1.Cells(iiZeile, 1)) - Year(WS2.Cells(iZeile, 3))
If .Comment Is Nothing Then
.AddComment WS2.Cells(iZeile, 2).Value & ": " & Chr(10) & Alter & " Jahre"
'=====================================================
' - Format der Geburtstage -
.Comment.Visible = True
With Selection.Font
.Name = "@Arial Unicode MS"
.FontStyle = "Fett"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 3
End With
With .Comment.Shape
.Line.Weight = 1.5
.Line.DashStyle = msoLineSolid
.Line.Style = msoLineSingle
.Line.Transparency = 0#
.Line.Visible = msoTrue
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.BackColor.RGB = RGB(255, 255, 255)
.Fill.Visible = msoTrue
.Fill.ForeColor.SchemeColor = 9
.Fill.BackColor.RGB = RGB(178, 178, 142)
.Fill.Transparency = 0#
.Fill.TwoColorGradient msoGradientFromCenter, 2
.LockAspectRatio = msoFalse
.Height = 70.5
.Width = 113.25
End With
'=====================================================
Else
.Comment.Text Text:=.Comment.Text & Chr(10) & WS2.Cells(iZeile, 2).Value & ": " & Chr(10) & Alter & " Jahre"
End If
End With
Next iZeile
'=========================================================
' - Format Rücksetzen von Feld B2 -
Range("B3").Select
Selection.Copy
Range("B2").Select
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
'=========================================================
Application.ScreenUpdating = True
PW_setzen
End Sub
=================================================================
Erst mal wird mir immer das Feld B2 dabei versaut, deshalb die
Rückstellung des Feldes und das Schlimme ist aber, das er zwar
bei Heute - 90 anfängt, dann aber bei 366 aufhört, wenn es den
Geburtstag schon gibt. Was habe ich falsch gemacht?
Wäre schön, wenn mir jemand den Fehler zeigen kann oder sagt,
was ich verändern muss.
Gruß
Andy