Brauch nochmal Hilfe: Worksheet_Change
Holger
mit eurer Hilfe habe ich in die Tabelleneigenschaften folgendes Makro eingebaut.
Es funktioniert einwandfrei, leider dauert es aber ewig wenn:
- man in mehreren Zellen gleichzeitig etwas einträgt
- und die Daten durch AutoFiler eingeschränkt sind.
Kann man das noch irgendwie verbessern?
Public Sub Worksheet_Change(ByVal Target As Range)
Dim RaBereich, RaBereich2 As Range, RaZelle, RaZelle2 As Range
Set RaBereich = Range("G7:R2000")
Set RaBereich = Intersect(RaBereich, Range(Target.Address))
Set RaBereich2 = Range("Q7:Q2000")
Set RaBereich2 = Intersect(RaBereich2, Range(Target.Address))
If Not RaBereich Is Nothing Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
For Each RaZelle In RaBereich
With RaZelle
If RaZelle.Value "" Then
RaZelle.Offset(0, -2) = "OK"
RaZelle.Offset(0, -2).Font.Color = vbBlue
Else
RaZelle.Offset(0, -2) = ""
End If
End With
Next RaZelle
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End If
Set RaBereich = Nothing
If Not RaBereich2 Is Nothing Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
For Each RaZelle2 In RaBereich2
With RaZelle2
If UCase(RaZelle2.Value) = "X" Then
RaZelle2.Offset(0, -1) = "PARTLY"
RaZelle2.Offset(0, -1).Font.Color = vbRed
RaZelle2.Value = Now()
RaZelle2.NumberFormat = "DD.MM.YYYY"
RaZelle2.Copy
RaZelle2.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
End With
Next RaZelle2
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End If
Set RaBereich2 = Nothing
End Sub