VBA-Beispiel 90
mail schreiben
mail schreiben

Zellwertänderung nach Neuberechnung anzeigen
Zellen mit Formeln deren Zellwert sich nach Neuberechnung ändert, sollen bis zum nächsten Speichern Schriftfarbe rot bekommen.

Das Makro muß in das Klassenmodul der Tabelle.

Die Datei zum download vba090.zip enthält noch zwei Varianten.
Option Explicit
Option Base 1

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Arr_Zellen()
Dim Anz_Formeln As Long, x As Long
Dim rng_Formeln As Range, Zelle As Range
Dim rng_neue_Werte As Range, rng_letzte_Formel As Range

'Anzahl der Zellen mit Formeln ermitteln
On Error Resume Next
Anz_Formeln = Cells.SpecialCells(xlCellTypeFormulas).Count
Error 0

On Error GoTo Hell

'Abbruch wenn keine Formeln vorhanden
If Anz_Formeln = 0 Then Exit Sub

'Array dimensionieren
ReDim Arr_Zellen(Anz_Formeln, 3)

'alle Zellen mit Formel als einen Bereich festlegen
Set rng_Formeln = Cells.SpecialCells(xlFormulas)

'Array mit den Zellen die Formeln haben füllen
For Each Zelle In rng_Formeln.Cells
      x = x + 1
      Arr_Zellen(x, 1) = Zelle.Row    'Zeile
      Arr_Zellen(x, 2) = Zelle.Column 'Spalte
      Arr_Zellen(x, 3) = Zelle.Value  'Zellwert
Next Zelle

Calculate 'Neuberechnung

Set rng_neue_Werte = Cells(Arr_Zellen(x, 1), Arr_Zellen(x, 2))
Set rng_letzte_Formel = rng_neue_Werte

'nach der Neuberechnung die aktuellen Zellwerte
'mit denen im Array vergleichen
'bei einem Unterschied, die Zelle in den Zellbereich
'rng_neue_Werte aufnehmen
For x = LBound(Arr_Zellen) To UBound(Arr_Zellen)
  On Error Resume Next
  If Cells(Arr_Zellen(x, 1), Arr_Zellen(x, 2)) <> Arr_Zellen(x, 3) Then
  Error 0
    Set rng_neue_Werte = Union(Cells(Arr_Zellen(x, 1), Arr_Zellen(x, 2)), rng_neue_Werte)
  End If
Next x

If Not IsEmpty(rng_neue_Werte) Then
  rng_neue_Werte.Font.ColorIndex = 3   'Schrift rot
End If

If rng_letzte_Formel = Arr_Zellen(UBound(Arr_Zellen), 3) Then
  rng_letzte_Formel.Font.ColorIndex = 0
End If

Set rng_Formeln = Nothing
Set rng_neue_Werte = Nothing
Set rng_letzte_Formel = Nothing
Erase Arr_Zellen
Exit Sub

Hell:
Erase Arr_Zellen
Set rng_Formeln = Nothing
Set rng_neue_Werte = Nothing
Set rng_letzte_Formel = Nothing

    MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
    & "Beschreibung: " & Err.Description _
    , vbCritical, "Fehler"

End Sub


Private Sub Worksheet_Activate()
  Application.Calculation = xlCalculationManual
End Sub
Private Sub Worksheet_Deactivate()
  Application.Calculation = xlCalculationAutomatic
End Sub
Download:   vba090.zip
relevante Links:

top