Macro activating as result of formula

[gazclose]

I've been looking on forums for the last couple of days and could only get so far so here I am all signed up.

My goal is to automatically send an e-mail if a figure drops below zero.

I have got as far as knowing I need to set up a macro and that I need some code to activate the macro. I managed to get all the way to setting up the macro and put in some code to activate it, i typed in -15 and boom it worked, woooohoooo i thought, then I put the formula in tested it out and no it wouldn't work. Bit more research and it seems that if you need it to check the result of a formula rather than a manually entered figure it gets a lot more complicated. I tried the advice on various threads and there was loads of good stuff out there but my complete lack of understanding when it comes to Visual has me banging my head off a brick well.

So I'm hoping one of you fine people can help out.

The macro seems to be all find coding wise but I will add the code anyway.

Sub Mail_ActiveSheet()
'Working in Excel 2000-2016
'For Tips see: [URL]http://www.rondebruin.nl/win/winmail/Outlook/tips.htm[/URL]
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With


    Set Sourcewb = ActiveWorkbook


    'Copy the ActiveSheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook


    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2016
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With


    '    'Change all cells in the worksheet to values if you want
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False


    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & ""
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)


    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = "gazclose@blah.com"
            .CC = ""
            .BCC = ""
            .Subject = "Civil Engineering LAP exceeds capacity"
            .Body = "Please be advised the Civil Engineering group LAP has exceeded capacity, please review."
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Send   'or use .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With


    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr


    Set OutMail = Nothing
    Set OutApp = Nothing


    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

So that part works fine, its the next part that I am having trouble with.

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If IsNumeric(Target) And Target.Address = "$D$15" Then
        Select Case Target.Value
        Case Is < 0: Mail_ActiveSheet
        End Select
    End If
End Sub

This simple wee guy works a treat but unfortunately if I have to manually input the figure the whole thing is pointless.

The formula I'm using in the cell couldn't be simpler. It's just "=sum(D14-D13)"

Thanks in advance.

 

[gazclose]

I'm not sure about the stop part of it, however I can confirm that it has entered "Test" into cell A1, so it appears to be working from that point of view. It will not change the value of cell A1 unless D15 is negative which is looking good I'm guessing?

 

[frank_AL]

That's correct. The code I just posted removes the part that was putting Test in A1 and should now call your Mail_Activate code module.

 

[gazclose]

It still had the test bit in, I deleted that and took the Call Mail_ActiveSheet out of quotes and now it appears to be working like a dream. I will do a bit more testing but I'm pretty sure thats it all sorted.

This concept could have a lot of uses with a little tweaking so this has been unbelievably useful. It has also helped my understanding a bit more!

 

[frank_AL]

Sorry, I still had the Call Mail_Activate commented out!

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim ws As Worksheet
Set ws = Sheets("Sheet1")


'   If cell in Col AL is changed on Worksheet "Report 3 Import - For PSOs" and Value of D15 changed to <0
If Target.Column = 38 Then
    If ws.Range("D15").Value < 0 Then
        Range("A1").Value = "Test"
        Call Mail_ActiveSheet
    End If
End If


End Sub

 

[gazclose]

Can you believe i'm back again

Everything has been going great and I was just about to update the live spreadsheet... slight snag, I probably should've mentioned this before. "Report 3 Import - For PSOs" This sheet is where we copy and paste the data from a report generated from a database, the info in column AL isn't manually entered. I copy from A to AQ and then refresh a pivot table, so I manually entered in a figure that I knew would create the condition to activate the macro but when I copied in and refreshed the table nothing happened.

Is this just turning into a nightmare now?

 

[frank_AL]

Okay, Let's try this, place this code on your Worksheet like the previous code. This code fires when the Pivot Table is Refreshed. See if that gets it done for you.
You are pushing me to the absolute brink of my knowledge here!

Private Sub Worksheet_Calculate()
Dim ws As Worksheet
Set ws = Sheets("Sheet1")


'   If Pivot Table is Updated
    If ws.Range("D15").Value < 0 Then
        Call Mail_ActiveSheet
    End If
End Sub

 

[gazclose]

haha well at least we're both learning! That seems to work fine except it is generating the e-mail twice...

Something I seen on another forum which may be of use was this bit of code, dunno if this might be of use?

<code style="margin: 0px; padding: 0px; border: 0px; font-family: Consolas, Menlo, Monaco, 'Lucida Console', 'Liberation Mono', 'DejaVu Sans Mono', 'Bitstream Vera Sans Mono', 'Courier New', monospace, sans-serif; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; vertical-align: baseline; white-space: inherit;">Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:C" & ThisWorkbook.Worksheets(1).UsedRange.Rows.Count)) Is Nothing Then
'Call your Macro to do stuff
End If
End Sub</code>