nach aktualisierung funktioniert Formel nicht mehr

Private Sub Worksheet_Change(ByVal Target As Range)
Set RaBereich = Range("n40:n500, q40:q500")
Set RaBereich = Intersect(RaBereich, Range(Target.Address))
If Not RaBereich Is Nothing Then
For Each RaZelle In RaBereich
With RaZelle
Select Case UCase(.Value)
Case Is > "0"
' Füllfarbe rot
.Interior.Color = 255
' Schriftfarbe schwarz
.Font.Color = 0
' Zellenformat tag monat jahr
'.NumberFormat = "dd.mm.yyyy"
'.Font.Bold = True
Case Else
' keine Füllfarbe
.Interior.ColorIndex = xlNone
' Schriftfarbe automatisch
' .Font.ColorIndex = xlAutomatic
' Zellenformat Standard
'.NumberFormat = "General"
End Select
End With
Next RaZelle
'ActiveSheet.protect ("Passwort")
'End If
Set RaBereich = Nothing                 ' Variable leeren
Exit Sub
End If
Set RaBereich = Range("o40:o500, r40:r500")
Set RaBereich = Intersect(RaBereich, Range(Target.Address))
If Not RaBereich Is Nothing Then
For Each RaZelle In RaBereich
'or Each RaZelle In RaBereich
With RaZelle
Select Case UCase(.Value)
Case Is > "0"
' Füllfarbe Orange
.Interior.Color = 65535
' Schriffarbbe schwarz
.Font.Color = 0
' Zellenformat Standard
.NumberFormat = "dd.mm.yyyy"
Case Else
' keine Füllfarbe
.Interior.ColorIndex = xlNone
' Schriftfarbe automatisch
.Font.ColorIndex = xlAutomatic
' Zellenformat Standard
.NumberFormat = "General"
End Select
End With
'Next RaZelle
'ActiveSheet.protect ("Passwort")
Next RaZelle
Set RaBereich = Nothing                 ' Variable leeren
Exit Sub
End If
Set RaBereich = Range("p40:p500, s40:s500")
Set RaBereich = Intersect(RaBereich, Range(Target.Address))
If Not RaBereich Is Nothing Then
For Each RaZelle In RaBereich
'or Each RaZelle In RaBereich
With RaZelle
Select Case UCase(.Value)
Case Is > "0"
' Füllfarbe Gelb
.Interior.Color = 5287936
' Schriffarbbe schwarz
.Font.Color = 0
' Zellenformat Standard
.NumberFormat = "dd.mm.yyyy"
Case Else
' keine Füllfarbe
.Interior.ColorIndex = xlNone
' Schriftfarbe automatisch
.Font.ColorIndex = xlAutomatic
' Zellenformat Standard
.NumberFormat = "General"
End Select
End With
'Next RaZelle
'ActiveSheet.protect ("Passwort")
Next RaZelle
Set RaBereich = Nothing                 ' Variable leeren
Exit Sub
End If
'

Private Sub Worksheet_Change(ByVal Target As Range)
'neu-Anfang
i = 0
Application.EnableEvents = False    ' Ereignisbehandlung ausschalten
'Anzahl ausgefüllte Zeilen in Spalte K ermitteln
With ActiveSheet
Do Until .Range("K40").Offset(i, 0) = ""
i = i + 1
Loop
If i > 0 Then
'Formeln in Spalte V einfügen
'Formel hier in der loalen Sprache/Syntax einfügen
' .Range(.Range("z40"), .Range("z40").Offset(i - 1, 0)).FormulaLocal = _
'    "=WENN(UND(R40=""X"";S40="""");""X"";WENN(UND(R40=""X"";W40=""X"");""X"";" _
'   & "WENN(UND(R40=""X"";S40=""X"");"""";)))"
'oder so - in VBA-Sprache - international US-(englisch) in R1C1-Schreibweise
.Range(.Range("V40"), .Range("V40").Offset(i - 1, 0)).FormulaR1C1 = _
"=IF(AND(RC[-6]>1,RC[-5]=""""),""X"",IF(AND(RC[-6]>1,RC[-3]>1),""X"",IF(AND(RC[-6] _
>1,RC[-5]>1),"""",)))"
'Formeln in Spalte W einfügen
'.Range(.Range("W40"), .Range("W40").Offset(i - 1, 0)).FormulaR1C1 = _
'  "=IF(R[0]C[-1]=""X"",Focus1!R23C44, """")"
Exit Sub
Application.EnableEvents = True    ' Ereignisbehandlung einschalten
'neu-Ende
End If
End With
End Sub

Private Sub CommandButton1_Click()
Call Archivieren
End Sub


Private Sub Archivieren()
' ActiveSheet.Unprotect    'Blattschutz aufheben
' Aus Tabelle Daten1 die zu archivierenden Datensätze in Tabelle Archiv verschieben
Dim bereich As Range, Zeilen As Object, Zähler As Long
Dim Zelle As Range, i As Long, ziel As Range, Arr As Variant
Set Zeilen = CreateObject("Scripting.Dictionary")
Set bereich = Me.Range("v40:v" & Me.Range("v" & Rows.Count).End(xlUp).Row)
For Each Zelle In bereich.Cells
If LCase(Zelle.Text) = LCase("X") Then
Set Zeilen(Zähler) = Zelle.Offset(0, 11 - Zelle.Column).Resize(1, 23)
Zähler = Zähler + 1
End If
Next Zelle
If Zähler = 0 Then Exit Sub
Zähler = Zähler - 1
Set ziel = Sheets("Archiv").Range("A65536").End(xlUp).Offset(1, 0)
Application.ScreenUpdating = False
'Werte übertragen
For i = 0 To Zähler
Arr = Zeilen(i).Value
ziel.Resize(1, Zeilen(i).Cells.Count).Value = Arr
Set ziel = ziel.Offset(1, 0)
Next i
'Werte löschen
For i = Zähler To 0 Step -1
Zeilen(i).EntireRow.Delete
Next i
Application.EnableEvents = True    ' Ereignisbehandlung einschalten
Zeilen.RemoveAll
'sortiert Daten1 ab zeile 40
ActiveSheet.Range("K40:W500").Select
Selection.Sort Key1:=ActiveSheet.Range("N40"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("K40:W200").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Exit Sub
End Sub


Vielleicht kann mir jemand helfen.

Angelika