Kommentrare trotz Blattschutz

Private Sub Workbook_Open()
'Automatisches Sperren der Arbeitsmappe
Dim i As Long
For i = 1 To Worksheets.Count
Sheets(i).Protect userinterfaceonly:=True, DrawingObjects:=True, AllowFiltering:=True,  _
Contents:=True, _
Scenarios:=True, Password:="hans"
Sheets(i).EnableOutlining = True
Next i
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim OldCellValue, NewComment, OldComment As String
Dim rng1, rng2, rng3, rng4, rng5, rng6, rng7, rng8, RngGes As Range
Set rng1 = Range("D11:APF15")
Set rng2 = Range("D17:APF21")
Set rng3 = Range("D23:APF27")
Set rng4 = Range("D29:APF33")
Set rng5 = Range("D35:APF39")
Set rng6 = Range("D41:APF45")
Set rng7 = Range("D47:APF61")
Set rng8 = Range("D63:APF67")
Set RngGes = Application.Union(rng1, rng2, rng3, rng4, rng5, rng6, rng7, rng8)
If Application.Intersect(Target, RngGes) Is Nothing Then Exit Sub
Dim RaBereich As Range                          ' Variable für Bereich
Dim RaZelle As Range                            ' Variable für Zelle
Set RaBereich = Union(rng1, rng2, rng3, rng4, rng5, rng6, rng7, rng8) ' Bereich der  _
Wirksamkeit
Set RaBereich = Intersect(RaBereich, Range(Target.Address))
If Not RaBereich Is Nothing Then                ' geänderte Zellen liegen im überwachten  _
Bereich
Application.EnableEvents = False            ' Reaktion auf Zellveränderung ausschalten
Application.ScreenUpdating = False          ' Bildschirmaktualisierung aus
For Each RaZelle In RaBereich               ' Schleife über alle geänderten Zellen im ü  _
_
berwachten Bereich
RaZelle.Value = UCase(RaZelle.Value)    ' Inhalt umwandeln in Groß
Next RaZelle
Application.ScreenUpdating = True           ' Bildschirmaktualisierung ein
Application.EnableEvents = True             ' Reaktion auf zellveränderung einschalten
End If
Set RaBereich = Nothing                         ' Variable leeren
OldCellValue = Target.Text
If Target.Cells.Count > 1 Then Exit Sub
NewComment = "Eintrag für " & Cells(Target.Row, 2).Text & " vom " & Now() & ", eingetragen   _
_
durch " & Environ("UserName") & ", Eintrag: " & OldCellValue
If Target.Comment Is Nothing Then
Target.AddComment NewComment
Else
OldComment = Target.Comment.Text
Target.Comment.Text NewComment & vbLf & OldComment
End If
Target.Comment.Shape.TextFrame.AutoSize = True
Target.Comment.Visible = True
DoEvents
Target.Comment.Visible = False
' Was soll bei entsprechenden Einträgen passieren...
If Target.Text = "" Then Target.Comment.Delete
If Target.Text = "VD" VD
If Target.Text = "GV" GV
If Target.Address = "$B$3" Then ActiveWindow.ScrollColumn = WorksheetFunction.Match(Range("  _
_
B3"), Range("D1:APD1"), 0) + 3
End Sub