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:
Private Sub Workbook_Open() 'Dieses Segment kannst du einem zweiten Button zuweisen'In das Klassenmodul "Diese Arbeitsmappe" um
Code eingefügt mit Syntaxhighlighter 1.14
'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
'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
'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
Gruss Rainer