AW: Zellen sollen nur kurz blinken, wenn neuer Wert
13.02.2018 18:49:07
Mullit
Hallo,
null Problemo, was Burak zurecht noch erwähnte, Du willst ja auch ungleiche abchecken, da müsstest Du ggf. noch aufstocken....
' **********************************************************************
' Modul: Tabelle1 Typ: Klassenmodul des Tabellenblattes
' **********************************************************************
Option Explicit
Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
ByRef pArray() As Any) As Long
Private mavntArray() As Variant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = Columns(1).Address Then _
mavntArray() = Cells(1, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row, 1).Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim objRange As Range, objColumn As Range
Set objColumn = Cells(1, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row, 1)
Set objRange = Intersect(Target, objColumn)
If Not objRange Is Nothing Then
Call Blinker(probjRange:=objRange)
mavntArray() = objColumn.Value
Set objRange = Nothing
End If
Set objColumn = Nothing
End Sub
Private Sub Blinker(ByRef probjRange As Range) '// © by Phelan /////
Dim objCell As Range, objUnion As Range
Dim sngTimer As Single
Dim sngStart As Single
Dim sngDuration As Single
Dim sngOn_Time As Single
Dim sngOff_Time As Single
Dim lngOn_Color As Long
Dim lngOff_Color As Long
sngDuration = 2.75!
sngOn_Time = 0.2!
lngOn_Color = vbRed
sngOff_Time = 0.2!
lngOff_Color = xlNone
If CBool(SafeArrayGetDim(mavntArray)) Then
For Each objCell In probjRange
If objCell.Value <> mavntArray(objCell.Row, 1) Then
If objUnion Is Nothing Then
Set objUnion = objCell
Else
Set objUnion = Union(objUnion, objCell)
End If
End If
Next
If Not objUnion Is Nothing Then
sngStart = Timer
With objUnion.Interior
Do While Timer - sngStart < sngDuration
.Color = lngOn_Color
sngTimer = Timer: Do While Timer < sngTimer + sngOn_Time: DoEvents: Loop
.ColorIndex = lngOff_Color
sngTimer = Timer: Do While Timer < sngTimer + sngOff_Time: DoEvents: Loop
Loop
End With
Set objUnion = Nothing
End If
Else
Call MsgBox("Bitte zur Initialisierung einmalig die " & _
"Eingabespalte selektieren...", vbExclamation)
End If
End Sub
VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel
Code erstellt und getestet in Office 14
...oder wie Burak schrieb mit ner Copy-Routine...
Gruß, Mullit