zwei Bereiche auf Änderungen überwachen
21.02.2014 10:06:46
Schmecks
nachdem letzens beim Erstellen einer Logdatei sehr geholfen wurde, wollte ich nun das Event Worksheet_Change um einen Bereich erweitern. Ich erzeuge in einer gesperrten und automatisch über Wenn-Bedingungen generierten Zelle folgende Zeichen:
1. "-" steht für in Bearbeitung / offen (Arial)
2. "ü" steht für in Erledigt (Wingdings)
3. "û" steht für in Problem (Wingdings)
Da ich die Schriftart nicht über eine bedingte Formatierung ändern kann, folgende Lösung über VBA. Leider funktiniert die Lösung nur in einer eingeständigen datei und nicht in Zusammenhang mit dem nachstehenden Code. Hier hätte ich gern Hilfe bzw. eine Erklärung.
Option Explicit
Dim intRow As Integer
Dim intDate As Long
Dim wks As Worksheet
Dim strAlterWert As String
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich As Range
Dim c As Range
Set Bereich = Range("B10:B3000") ' Bereich der Wirksamkeit
If InStr(Target.Address, ":") = 0 Then ' wurden mehere Zellen markiert ist Wert größer 0
If Intersect(Target, Bereich) Is Nothing Then Exit Sub ' Abbruch, wenn Aktion nicht im _
Zielbereich
ActiveSheet.Unprotect ("abc")
For Each c In Target
Select Case LCase(c.Value)
Case "-": c.Font.Name = "Arial"
c.Font.ColorIndex = 5
c.Font.Size = 10
Case "ü": c.Font.Name = "Wingdings"
c.Font.Size = 10
Case "û": c.Font.Name = "Wingdings"
c.Font.Size = 10
Case Else
c.Font.ColorIndex = 0
End Select
Next
'ActiveSheet.Protect ("abc")
End If
Set wks = Worksheets("Log")
If Intersect(Range("C10:AD3000"), Target) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
On Error Resume Next
Application.ScreenUpdating = False
wks.Unprotect ("abc")
With wks
intRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(intRow, 1).Value = ActiveSheet.Name
.Cells(intRow, 2).Value = Target.Address(0, 0)
.Cells(intRow, 3).Value = strAlterWert
.Cells(intRow, 4).Value = Target.Value
.Cells(intRow, 5).Value = Application.UserName
.Cells(intRow, 6).Value = Environ("Computername")
.Cells(intRow, 7).Value = Date
.Cells(intRow, 8).Value = Time
End With
wks.Protect ("abc")
Application.ScreenUpdating = True
On Error GoTo 0
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Range("C10:AD3000"), Target) Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
strAlterWert = Target.Value
ErrorExit:
End Sub
mfg der Schmecks