Macro when a font in a range changes

  • Thread starter Thread starter Tornados
  • Start date Start date
T

Tornados

Hello there!

below i added the code i'm using to run a macro when a certain value i
a specified range changes.. However i changed some things and it shoul
now not look at values but at the format (font color changes, an
becomes bold)....

However, i'm getting type mismatch errors when i replace range.value b
range.font.colorindex.... It seems logical to me i guess yet.. exce
things differently :)

Hope you can help out..

==========
Option Explicit
Sub Worksheet_Calculate()
Static dLastSent As Double
Static myVals As Variant

Dim iRow As Long
Dim iCol As Long
Dim myRng As Range
Dim SomethingChanged As Boolean

If dLastSent = 0 Then dLastSent = Now - TimeValue("02:00:00")


'If Now >= (dLastSent + TimeValue("02:00:00")) Then


Set myRng = Me.Range("c4:k27")

If IsEmpty(myVals) Then
myVals = myRng.Font.ColorIndex



Else
SomethingChanged = False

For iRow = LBound(myVals, 1) To UBound(myVals, 1)
For iCol = LBound(myVals, 2) To UBound(myVals, 2)

If myVals(iRow, iCol) = myRng.Cells(iRow
iCol).Font.ColorIndex Then
'do nothing--no change here
Else
SomethingChanged = True
dLastSent = Now
Call CDO_Send
Exit Sub
End If
Next iCol
Next iRow

If SomethingChanged Then
myVals = myRng.Font.ColorIndex
End If
End If

' End If



End Su
 
Hi
no possible to react on a format change. The worksheet_change event is
NOT triggered if you only change the format
 
Well, in fact it does Frank..

Remember the previous macro also worked and the sheet just runs.
through a dde feed input changes and it notices the value changes in
certain cell withough me interfering...

So because something infact changes in the worksheet, it calculate
which triggers my macro....

So again, the worksheet_calculate isn't the problem, but the macr
itself...
 
Hi
o.k. I see: You're just lucky that your spreadsheet is re-calculated
often enough to see a font change nearly in real-time :-)
But believe me if you would disable your DDE link and ONLY change a
font color no event procedure would be triggered. But this is in your
case more an academic issue :-)

Problem is that the assignment of a range value to a matrix works just
fine but for the font properties you have to loop through the range
manually and assign all individual properties to your array variable
 
Hmm Tx but it isn't working i'm afraid.. still the type mismatch.
getting the feeling i'm missing something obvious.

========

Sub Worksheet_Calculate()
Static dLastSent As Double
Static myVals As Variant

Dim iRow As Long
Dim iCol As Long
Dim myRng As Range
Dim SomethingChanged As Boolean

If dLastSent = 0 Then dLastSent = Now - TimeValue("02:00:00")


'If Now >= (dLastSent + TimeValue("02:00:00")) Then


Set myRng = Me.Range("c4:k27")

If IsEmpty(myVals) Then

For iRow = LBound(myVals, 1) To UBound(myVals, 1)
For iCol = LBound(myVals, 2) To UBound(myVals, 2)


myVals(iRow, iCol) = myRng.Cells(iRow, iCol).Font.ColorIndex

Next
Next


Else
SomethingChanged = False

For iRow = LBound(myVals, 1) To UBound(myVals, 1)
For iCol = LBound(myVals, 2) To UBound(myVals, 2)

If myVals(iRow, iCol) = myRng.Cells(iRow
iCol).Font.ColorIndex Then
'do nothing--no change here
Else
SomethingChanged = True
dLastSent = Now
Call CDO_Send
Exit Sub
End If
Next iCol
Next iRow

If SomethingChanged Then
myVals = myRng.Font.ColorIndex
End If
End If

' End If



End Su
 
Hi
proble is that you don't have set the array ranges. Try the following:

'....
If IsEmpty(myVals) Then
myVals = myRng.Value 'new line to set the boundaries
For iRow = LBound(myVals, 1) To UBound(myVals, 1)
For iCol = LBound(myVals, 2) To UBound(myVals, 2)
myVals(iRow, iCol) = myRng.Cells(iRow, iCol).Font.ColorIndex
Next
Next
'....
 
Well that loop worked fine before :(..

Could it be that i have to redim the array?

i'm not sure what exact the procedure was again...

first it is :

static myvals as variant

should it be myvals() or something?

and then redim after i set the range?
I tried it but that also didn't work, it might be i did something wron
here.
 
Hi
i tested this and it worked for me. Have you added this additional line
myVals = myrng.value

I used this line to dim your array correctly. Afterwards loop through
the range and insert the font.colorindex values
 
Damn I hoped i out'edited' you....

Anyway, indeed it works (i forgot to do the same in the end of the
code)...


However, somehow the macro isn't getting send... Filling the array is
fine now though...
If myVals(iRow, iCol) = myRng.Cells(iRow,
iCol).Font.ColorIndex Then
Click to expand...

I think things are messing up in this line... can' figure out why...
 
Hmmm -4105 for the myvalue :s

somehow all values in the matrix are -4105.... very weird.. The thin
is that i'm using conditional formatting and the actual colorindice
are clearly not changed underlying?

Damnit.. have to look for an alternative then.
 
Hi
a now I see: Yes conditional formats do NOT change the colorindex
property. In this case you have to use something else :-)
 
Bah.... Well this is basically my question now , I hope someone has a
idea cause i don't anymore... :(


=========
I have a range that is being monitored.. conditional formats change s
now and then.. (following dde updates) and when that happens I need
macro to be runned.....
========
 
Hi
I would monitor the cell values (and replicate the conditions of your
format in your macro). I think Bob Phillips 7 Harlan Grove posted some
code some months ago to also check the conditional format conditions
8maybe they'll step in and provide you with this code)
 
Actually, I just completed a vb code to monitor a dde link an
automatically sends an email. It only send s the email whenever th
dde link passes through a specified target and back. If I didn't hav
a comparater then an email would be sent everytime the link change
value wheteher it was in our out of target range.
The key to this is to have a formula that recalculates the dde link.
In itself it doesn't need to do anything in the vb but this vb cod
requires a calculation to start it. Evertime the dde link valu
changes it automatically calculates. The only problem with this cod
is that when the excel sheet opens, the link is not refreshed and th
code takes a dump, just click ignore and it will complete updating th
dde link and every change after that will re-calculate

Here is the code:

Private Sub Worksheet_Calculate()

'Check to see if it isn alarm
If Range("C11").Value > Range("E11").Value Then
Range("B11") = 1

'Check to see if Reset
ElseIf Range("C11").Value < Range("F11").Value Then
Range("B11") = 0


End If

'If in alarm send email
If Range("B11") > Range("D11") Then
Application.Run ("AutoEmail2.xls!Sheet1.Macro1")

'If in Ok send email
ElseIf Range("B11") < Range("D11") Then
Application.Run ("AutoEmail2.xls!Sheet1.Macro2")
End If

End

End Sub
Sub KeyCell()
Dim Cell As Object
Dim myOutlook As Object
Dim myMailItem As Object
' Make instance
Set myOutlook = CreateObject("Outlook.Application")
' Make mail item
Set myMailItem = myOutlook.createitem(0)
' Set recipient (internal mail)
myMailItem.Recipients.Add Range("H11")
'myMailItem.Recipients.Add Range("I11")
' Set recipient (external mail)
'myMailItem.Recipients.Add "(e-mail address removed)"
' Set subject
myMailItem.Subject = "Compressed Air Dewpoint out of Tolerance"
' Set body
myMailItem.Body = "Compressed Air Dewpoint is Out of Tolerance"
vbCr & "At " & Now() & " the dewpoint transitioned to greater than -4
Deg F!" & vbCr & vbCr & "Facilities will investigate cause." & vbCr
vbCr & "This email was automatically generated by METASYS"
' And send it!
myMailItem.send
' Close instance
Set myOutlook = Nothing

End
End Sub

Sub KeyCell2()
Dim Cell As Object
' If the values in A11:C11 are greater than 50...
'For Each Cell In Range("B11")
' ' If Cell > -40 Then
Dim myOutlook As Object
Dim myMailItem As Object
' Make instance
Set myOutlook = CreateObject("Outlook.Application")
' Make mail item
Set myMailItem = myOutlook.createitem(0)
' Set recipient (internal mail)
myMailItem.Recipients.Add Range("H11")

' or insert email address after Add ex.
'myMailItem.Recipients.Add "Gene, Bub"

'myMailItem.Recipients.Add Range("I11")
' Set recipient (external mail)
'myMailItem.Recipients.Add "(e-mail address removed)"
' Set subject
myMailItem.Subject = "Compressed Air Dewpoint is back i
Tolerance"
' Set body
myMailItem.Body = "Compressed Air Dewpoint is back in Tolerance"
vbCr & "At " & Now() & " the dewpoint transitioned to Less than -40 De
F!" & vbCr & vbCr & "This email was automatically generated b
METASYS"
' And send it!
myMailItem.send
' Close instance
Set myOutlook = Nothing

End
End Sub

Sub Macro1()
'
' Macro1 Macro
' Macro recorded 6/9/2004 by redwar2x
'

' This macro prompts the another macro to send email when the dde lin
transitions to Bad


If Range("B11") <> Range("D11") Then

Range("B11").Select
Selection.Copy
Range("D11").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End If
Application.Run ("AutoEmail2.xls!Sheet1.KeyCell")
End
End Sub



Sub Macro2()
'
' Macro1 Macro
' Macro recorded 6/9/2004 by redwar2x
'

' This macro prompts the another macro to send email when the dde lin
transitions to good

If Range("B11") <> Range("D11") Then


Range("B11").Select
Selection.Copy
Range("D11").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End If
Application.Run ("AutoEmail2.xls!Sheet1.KeyCell2")
End
End Sub


Hope this helps!
Bu
 
Back
Top