Bei Zellenwertänderung Sound, Farbe und kopieren

Question

Hallo liebe Community,
ich habe ein Problem mit der Verarbeitung einer dynamischen Zelle. Denn diese Zelle wird mit einem Realtime Börsenkurs via Makro alle fünf Sekunden gespeist. Nun kann ich mit dieser Zelle aber leider nicht weiter arbeiten, da ich nicht weiß wie man sich auf vorangegangene Werte in der selben Zelle bezieht :(
Die Aufgabe lautet: Die dynamische Zelle ändert ihre Farbe sobald sich der Wert zum Vorwert verändert. Die Farbe soll rot werden wenn der neue Wert niedriger als der vorangegangene Wert ist. Steigt der Wert, so soll sich die Zelle grün färben. Zusätzlich soll "Sound1" ertönen wenn sich die Zelle im Wert positiv verändert und "Sound2" wenn sich der Wert verringert.
Ferner soll im Zuge eines neu eingehenden Wertes dieser in ein anderes Arbeitsblatt kopiert und jeder weitere neue Wert darunter gelistet werden, sodass eine Historie entsteht.
Bin für jeden Denkansatz dankbar!

Answer 1

'Hallo Hagus,

Falls du noch keine Lösung gefunden haben solltest, hier mal mein
"Denkansatz":

'leider hast du nichts geschrieben, auf welche Weise du an die
Börsenwerte kommst. Hast du Zugriff auf den hinterlegten Code?
Wenn ja gibt es dort sicher irgendwo eine Zeile wie
Range("A1").value = "www..." Ersetze diese Zeile durch
Dim Kurs As Double
Kurs = "www..."
WertVerarbeiten Range("A1"), Kurs

Füge nun ein Standardmodul ein, (Menü Einfügen --> Modul) wo du
die Subs WertSpeichern und WertVerarbeiten des folgenden Codes
hinterlegst.

Solltest du nicht an den Code rankommen, wird der Wert
wahrscheinlich per Formel gezogen. Du kannst dann per Code
prüfen ob sich der Wert geändert hat. Füge dazu im Modul
DieseArbeitsmappe diesen Code ein:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.OnTime Startzeit, "WertPruefen", Schedule:=False
End Sub

Private Sub Workbook_Open()
NeuerKurs
End Sub

sowie in einem Standardmodul (z.B. Modul1) diesen Code:

Dim AltWert As Double
Public Startzeit
Private Declare Function Beep Lib "kernel32" (ByVal Fq As Long,
ByVal Tm As Long) As Long


Sub WertVerarbeiten(Zelle As Range, Kurs As Double)

KleinerWechsel = 0.01
GroßerWechsel = 0.05

If Kurs < AltWert Then
Zelle.Interior.Color = 255
If Kurs < AltWert - KleinerWechsel Then
Beep 400, 150
ElseIf Kurs < AltWert - GroßerWechsel Then
Beep 250, 400
End If
ElseIf Kurs > AltWert Then
Zelle.Interior.Color = 13434828
If Kurs > AltWert + KleinerWechsel Then
Beep 600, 150
ElseIf Kurs > AltWert + GroßerWechsel Then
Beep 850, 400
End If
End If
WertSpeichern Kurs
NeuerKurs

Set AktBlatt = Sheets("Tabelle1")
AltWert = AktBlatt.Range("A1").Value
End Sub

Sub NeuerKurs()
'Startzeit = Now + TimeValue("0:00:05")
'Application.OnTime Startzeit, "WertPruefen"
End Sub

Sub WertPruefen()
Set AktBlatt = Sheets("Tabelle1")
WertVerarbeiten AktBlatt.Range("A1"), AktBlatt.Range("A1").Value
End Sub
Sub WertSpeichern(Kurs)

Set Blatt = Sheets("Tabelle2")
Spalte = Blatt.Cells(1, Columns.Count).End(xlToLeft).Column
If Blatt.Cells(1, Spalte) < Date Then
Spalte = Spalte + 1
Blatt.Cells(1, Spalte).Value = Date
End If
Zeile = Blatt.Cells(Rows.Count, Spalte).End(xlUp).Row
If InStr(9, Blatt.Cells(Zeile, Spalte), Kurs) = 0 Then
Zeile = Zeile + 1
Blatt.Cells(Zeile, Spalte).Value = Time & " " & Kurs
End If

End Sub

Zur Erklärung. Application.Ontime prüft alle 5 sekunden, ob
sich der Wert geändert hat. Mit Beep löst du einen Sound aus. Je
höher der erste Wert, desto höher der Ton, je höher der zweite Wert,
desto länger dauert der Ton. Damit du nicht alle 5 Sekunden von
Pieptönen genervt wirst, wird der Sound nur ausgelöst, wenn sich
der Kurs um einen bestimmten Wert verändert hat.

Damit hast du nun zwei mögliche Wege, dein Problem anzugehen.
Wie genau, du allerdings deinen Kurs ziehst, würde mich schon
auch interessieren. Vielleicht gibt es ja hier später mal jemanden
der etwas ähnliches umsetzen will.

Gruß Mr. K.

Answer 2

Im Fall der Kursaktualisierung per Formel solltest du die Apostroph-
Zeichen in der Sub "NeuerKurs" löschen, damit das funktioniert. Die
hatte ich nur vorübergehend gesetzt, um Fall1 auszutesten.

Außerdem wurde die Zeile ganz oben beim Einfügen leider
umgebrochen. Damit das funzt, muss noch ein Unterstrich rein.
Private Declare Function Beep Lib "kernel32" (ByVal Fq As Long, _
ByVal Tm As Long) As Long

Answer 3

Mist, noch ein Bug drin:
Damit du die Datei im Fall der Formelaktualisierung überhaupt
erstmalig speichern und schließen kannst, ergänze die eine Sub im
Modul DieseArbeitsmappe wie folgt:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.OnTime Startzeit, "WertPruefen", Schedule:=False
End Sub
So nun sollte es aber wieder klappen. :-)