@ Andi: Automatische Kontrolle eines Zellwertes

ich weiss nicht ob du den anderen Thread noch verfolgst, deshalb hier ein Neuanfang.

Das Makro wurde insoweit verfeinert, dass du die Zelle frei in der aktiven Tabelle wählen kannst.

Starten kannst du die Prüfung mit dem Makro "Start_Cell_Control" und beenden kannst du das Makro mit "Stop_Cell_Control".

Viel Spass:

'In das Klassenmodul "Diese Arbeitsmappe" um
'Prüfstatus auf "True" zu setzen. Sonst kann
'die Prüfung nicht gestartet werden
Public CtrlValue, Mldg As Long, StartCtrl As Boolean
Public myCell As Range, wks As String, wbk As String
Public Qe As Integer

Private Sub Workbook_Open()
'Entfernen des Hochkommas vor Ctrl_Each_Minute startet die
'Control-Routine beim öffnen der Arbeitsmappe
'Wenn das Hochkomma nicht entfernt wird, startet
'die Prüfung nur, wenn Sie über einen Button oder
'"Makro ausführen" gestartet wird
'---
'Ctrl_Each_Minute
'---
'Prüfstatus auf "True" = "Ja, die Prüfung darf durchgeführt werden" setzen.
StartCtrl = True
End Sub

'In ein Modul
'------------
'Dieses Segment kannst du einem Button zuweisen
'um die Prüfung zu starten
Sub Start_Cell_Control()
'Prüfstatus auf True setzen
StartCtrl = True
'....
Set myCell = Application.InputBox("Wählen Sie die Zelle , die geprüft werden soll", "Zellüberwachung starten", "A1", , , , , Type:=8) 'Zelle die geprüft werden soll
'Prüfung ob mehr als eine Zelle markiert wurde
If InStr(1, ":", myCell.Address) > 0 Then
    Qe = MsgBox("Es wurde mehr als eine Zelle markiert", vbCritical + vbOKOnly, "Prüfung abgebrochen")
    Exit Sub
End If
'Es wird automatisch der Name der gewählten Tabelle übernommen
wks = ActiveSheet.Name 'Tabelle in welcher der Wert steht
wbk = ActiveWorkbook.Name
'Beim ersten Start muss die Variable geprüft und gefüllt werden
If IsEmpty(CtrlValue) Then
    CtrlValue = Workbooks(wbk).Worksheets(wks).Range(myCell.Address)
    Mldg = 0
End If
'Start des Makros
Control_each_Minute
End Sub

'Dieses Segment kannst du einem zweiten Button zuweisen
'um die Prüfung wieder anzuhalten
Sub Stop_Cell_Control()
Dim Msg As Integer
    'Die Variable wird auf False gesetzt
    'beim nächsten Makrostart "Control_Each_Minute"
    'wird der Status geprüft. Wenn "False" dann
    'wird keine weitere Prüfung mehr vorgenommen
    StartCtrl = False
    Msg = MsgBox("Die Prüfung der Zelle wurde angehalten", vbInformation + vbOKOnly, "ACHTUNG")
End Sub

'Dieses Segment ist die eigentliche Prüfprozedur
Sub Control_each_Minute()
'Variablen erstellen
Dim Msg As String
'Prüfung ob die Kontrolle gestoppt werden soll
'Wenn die Variable StartCtrl auf False steht wird das Makro gestoppt
If StartCtrl = False Then
    Exit Sub
End If
'Variablen vorbereiten
Msg = ""
'Start für die nächste Kontrolle
Application.OnTime Now() + TimeValue("00:00:10"), "control_each_Minute"
'Meldung wenn der Wert geändert wurde
If Workbooks(wbk).Worksheets(wks).Range(myCell.Address) <> CtrlValue Then
    Msg = "Der Kontrollwert in" & Chr$(13) & wbk & " " & wks & "!" & myCell.Address & ": " & CtrlValue & Chr$(13) & "hat sich geändert." & Chr$(13)
    Msg = Msg & "Möchten Sie den neuen Wert " & Workbooks(wbk).Worksheets(wks).Range(myCell.Address) & " als Kontrollwert übernehmen ?"
    If Mldg > 0 Then
        Qe = MsgBox(Msg, vbCritical + vbYesNo + vbDefaultButton1, "ACHTUNG:   " & Mldg & ".    ÄÄnderungsinformation")
            If Qe = 6 Then
                'Übernahme des neuen Wertes als Control wert
                CtrlValue = Workbooks(wbk).Worksheets(wks).Range(myCell.Address)
                'Zurücksetzen des Counters
                Mldg = 0
                Exit Sub
        End If
        'Aufaddieren des Counters
        Mldg = Mldg + 1
    Else
        Qe = MsgBox(Msg, vbCritical + vbYesNo + vbDefaultButton1, "ACHTUNG: ÄÄnderungsinformation")
            If Qe = 6 Then
                'Übernahme des neuen Wertes als Control wert
                CtrlValue = Workbooks(wbk).Worksheets(wks).Range(myCell.Address)
                'Zurücksetzen des Counters
                Mldg = 0
                Exit Sub
        End If
        'Aufaddieren des Counters
        Mldg = Mldg + 1
    End If
End If
End Sub