VBA Kommentar bei MouseOver
06.01.2020 12:24:52
Peer
In meinem Projekt, dass mit eurer Hilfe zu etwas Großem gewachsen ist, möchte ich ein paar kleine Anpassungen machen. Dabei habe ich hier im Forum folgenden Code gefunden, den ich gern in mein Projekt integrieren möchte, ohne alles von vorn zu machen.
Hier wird aus dem Sheet "Feiertage", das bei mir auch so heißt, aus Spalte A (wie bei mir) der Wert ausgelesen und beim Erzeugen der Mappe als Kommentar in den neu erzeugten Kalender eingefügt, bei dem man mit MouseOver den entsprechende zugeordneten Wert angezeigt bekommt.
Sub Main()
Dim wks As Worksheet
Dim cmt As Comment
Dim vYear As Variant
Dim iRow As Integer
Dim bln As Boolean
Application.ScreenUpdating = False
bln = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Set wks = ActiveSheet
vYear = InputBox( _
prompt:="Gewünschtes Kalenderjahr angeben:", _
Default:=Year(Date))
Range("C1").Value = CInt(vYear)
Workbooks.Add 1
Call MonateAnlegen
Call TageEintragen
iRow = 1
Do Until IsEmpty(wks.Cells(iRow, 1))
With Worksheets(Month(wks.Cells(iRow, 2).Value))
With .Cells(Day(wks.Cells(iRow, 2).Value), 1)
.Interior.ColorIndex = 36
Set cmt = .AddComment(wks.Cells(iRow, 1).Value)
cmt.Shape.TextFrame.AutoSize = True
End With
End With
iRow = iRow + 1
Loop
Application.DisplayStatusBar = bln
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Private Sub MonateAnlegen()
Dim iMonth As Integer
For iMonth = 1 To 12
If iMonth > 1 Then
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
End If
ActiveSheet.Name = Format( _
DateSerial(Range("C1").Value, iMonth, 1), "mmmm")
Next iMonth
End Sub
Private Sub TageEintragen()
Dim wks As Worksheet, wksMy As Worksheet
Dim lDay As Long
Dim iMonth As Integer, iDay As Integer
Set wksMy = ThisWorkbook.Worksheets("Feiertage")
For iMonth = 1 To 12
Set wks = Worksheets(iMonth)
Application.StatusBar = "Bearbeite Monat " & wks.Name
wks.Columns(1).NumberFormat = "dd.mm.yy"
wks.Columns(2).NumberFormat = "dddd"
For lDay = DateSerial(wksMy.Range("C1").Value, iMonth, 1) To _
DateSerial(wksMy.Range("C1").Value, iMonth + 1, 0)
iDay = iDay + 1
wks.Cells(iDay, 1) = lDay
wks.Cells(iDay, 2) = lDay
If WeekDay(lDay) = 7 Then
wks.Cells(iDay, 1).Interior.ColorIndex = 34
wks.Cells(iDay, 2).Interior.ColorIndex = 34
ElseIf WeekDay(lDay) = 1 Then
wks.Cells(iDay, 1).Interior.ColorIndex = 35
wks.Cells(iDay, 2).Interior.ColorIndex = 35
End If
Next lDay
iDay = 0
Next iMonth
Worksheets(1).Select
ActiveWindow.Caption = "Jahreskalender " & wksMy.Range("C1").Value
End Sub
Auch bei mir wird jedes Jahr der vorhandene Kalender durch Eingabe der Jahreszahl neu erstellt, nur nicht als neue Mappe, sondern nur durch Löschen und Einfügen der Daten. Auch farbliche Akzente, wie Wochenende und Schulferien werden berücksichtigt. Der einzuige Unterschied meiner Meinung nach ist, das bei mir die Jahreszahl nicht in das Sheet "Feiertage" in C1 geschrieben wird, sondern in Sheet "Gesamtstunden" B25.
Sub Neues_Jahr(control As IRibbonControl)
Dim lngYear As Long, lngMonth As Long, lngDay As Long
Dim datDay As Date, varFerien As Variant, varFeiertage As Variant
Dim bolHolyday As Boolean
On Error GoTo ERRORHANDLER
With Application
.ScreenUpdating = False
.EnableEvents = False
.AskToUpdateLinks = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
frm_Jahr.Show
Application.Calculate
ActiveWorkbook.Unprotect
lngYear = Sheets("Gesamtstunden").Range("B25")
For lngMonth = 1 To 12
With Sheets(Format(DateSerial(lngYear, lngMonth, 1), "mmmm"))
.Unprotect
'Zellen leeren und Formate entfernen
With .Range("B12:C42")
.ClearContents
.Font.ColorIndex = xlAutomatic
.Font.Bold = False
.Interior.ColorIndex = xlNone
End With
.Range("D12:E42,G12:L42,P12:U42,X12:X42,Z12:AK42").ClearContents
'vom 1.Tag des Monats bis zum letzten
For lngDay = 1 To Day(DateSerial(lngYear, lngMonth + 1, 0))
'Datum ermitteln
datDay = DateSerial(lngYear, lngMonth, lngDay)
'In 'Feietage' das Datum suchen
varFeiertage = Application.Match(CLng(CDate(datDay)), Sheets("Feiertage").Range(" _
Feiertage").Columns(2), 0) 'Fehler gefunden
'In 'Ferien' das Datum suchen - kleiner oder gleich
varFerien = Application.Match(CLng(datDay), Sheets("Ferien").Range("Bayern").Columns(1), _
1)
bolHolyday = False
'Wenn Datum gefunden, dann vergeichen ob das Enddatum auch im Bereich liegt
If IsNumeric(varFerien) Then
bolHolyday = Sheets("Ferien").Range("Bayern").Cells(varFerien, 2) >= datDay
End If
'Die Datumszellen
With .Range(.Cells(lngDay + 11, 2), .Cells(lngDay + 11, 3))
.Value = datDay 'Datum eintragen
'Wenn Wochentag größer Freitag, dann rote Schriftfarbe
If Weekday(datDay, vbMonday) > 5 Or IsNumeric(varFeiertage) Then .Font.ColorIndex = 3
'Wenn Wochentag ist Sonntag oder es ist ein Feiertag, dann Fettschrift
.Font.Bold = Weekday(datDay, vbMonday) = 7 Or IsNumeric(varFeiertage)
'Wenn Datum innerhalb eines Ferienbereiches liegt, dann Hintergrund Hellgrün
If bolHolyday Then .Interior.Color = RGB(235, 241, 222)
End With
Next
.Protect
End With
Next
ActiveWorkbook.Protect
Sheets("Januar").Select
Range("D12").Select
ERRORHANDLER:
If Err.Number 0 Then
MsgBox "Fehler in con_Jahr_neu" & vbLf & vbLf & "Prozedur:" & vbTab & "Neues_Jahr" & vbLf & _
"Nummer:" & vbTab & Err.Number & vbLf & "Meldung:" & vbTab & Err.Description & vbLf & _
IIf(Erl, "Zeile:" & vbTab & Erl, ""), vbExclamation, "Fehler!"
Err.Clear
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.AskToUpdateLinks = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Wie kann ich den Code so anpassen, dass die Routine auch bei mir funktioniert?
Ich habe mal ein paar Punkte rausgesucht, die für mich eventuell in Frage kommen sollten.
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Set wksMy = ThisWorkbook.Worksheets("Feiertage")
For lDay = DateSerial(wksMy.Range("C1").Value, iMonth, 1) To _
DateSerial(wksMy.Range("C1").Value, iMonth + 1, 0)
iDay = iDay + 1
wks.Cells(iDay, 1) = lDay
wks.Cells(iDay, 2) = lDay
If WeekDay(lDay) = 7 Then
wks.Cells(iDay, 1).Interior.ColorIndex = 34
wks.Cells(iDay, 2).Interior.ColorIndex = 34
ElseIf WeekDay(lDay) = 1 Then
wks.Cells(iDay, 1).Interior.ColorIndex = 35
wks.Cells(iDay, 2).Interior.ColorIndex = 35
End If
Next lDay
Kann mir jemand bei Entwirren helfen?
LG
Peer