Macro to take date of Pivot results to Outlook msg template fields

Hi there,

This will not look at the PivotTable, but the data source on your Data worksheet.  Please note that it does not enter an email address, nor does it automatically send the email, but rather just displays it.  This code should go into a standard module of the workbook which houses this data.

Option Explicit

Sub SendAlertEmail()

    '/// Reference set to (Tools | References):
    '///   Microsoft Outlook 14.0 Object Library
    '///   Microsoft Scripting Runtime

    Dim WS                      As Worksheet
    Dim rCheck                  As Range
    Dim rAlert                  As Range
    Dim rCell                   As Range
    Dim rData                   As Range
    Dim OL                      As Outlook.Application
    Dim olMail                  As Outlook.MailItem
    Dim bOLOpen                 As Boolean
    Dim oDic                    As New Scripting.Dictionary
    Dim vKey                    As Variant
    Dim sBody                   As String

    Call TOGGLEEVENTS(False)

    Set WS = ThisWorkbook.Worksheets("Data")
    Set rData = WS.Range("A1:G" & WS.Cells(WS.Rows.Count, 1).End(xlUp).Row)

    For Each rCell In WS.Range("F2", WS.Cells(WS.Rows.Count, "F").End(xlUp)).Cells
        If oDic.Exists(rCell.Value) = False Then
            If Evaluate("=COUNTIFS('Data'!F:F,""Team1"",'Data'!G:G,""Yes"")") > 0 Then
                oDic.Add rCell.Value, rCell.Value
            End If
        End If
    Next rCell

    bOLOpen = True
    On Error Resume Next
    Set OL = GetObject(, "Outlook.Application")
    If OL Is Nothing Then
        Set OL = CreateObject("Outlook.Application")
        bOLOpen = False
    End If
    On Error GoTo 0

    WS.Range("C:C,F:F,G:G").EntireColumn.ColumnWidth = 0
    For Each vKey In oDic.Items

        Set olMail = OL.CreateItem(olMailItem)

        olMail.Subject = oDic.Item(vKey) & " - 1 Day Alert - Orders Due"

        rData.AutoFilter 6, oDic.Item(vKey)
        rData.AutoFilter 7, "Yes"

        olMail.HTMLBody = RangetoHTML(rData.SpecialCells(xlCellTypeVisible))

        WS.AutoFilterMode = False

        olMail.Display

    Next vKey

    WS.Cells.EntireColumn.AutoFit

    If bOLOpen = False Then OL.Quit

    Call TOGGLEEVENTS(True)

End Sub

Function RangetoHTML(rng As Range)
    ' Graciously used/adapted from http://www.rondebruin.nl/mail/folder3/mail4.htm
    ' By Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2010

    Dim fso                     As Object
    Dim ts                      As Object
    Dim TempFile                As String
    Dim wbTemp                  As Workbook
    Dim wsTemp                  As Worksheet

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set wbTemp = Workbooks.Add(1)
    Set wsTemp = wbTemp.Worksheets(1)
    wsTemp.Range("A1").Value = "1 Day Alert - Orders due within 1 working day"
    wsTemp.Range("A3").Value = "Please be aware that these orders are due within 1 day. Please provide an update on the status."
    wsTemp.Range("A5").PasteSpecial Paste:=8
    wsTemp.Range("A5").PasteSpecial xlPasteValues, , False, False
    wsTemp.Range("A5").PasteSpecial xlPasteFormats, , False, False
    wsTemp.Range("A5:D5").Font.Bold = True
    wsTemp.Range("A5:D" & wsTemp.Cells(wsTemp.Rows.Count, 1).End(xlUp).Row).BorderAround xlContinuous
    wsTemp.Range("A5:D" & wsTemp.Cells(wsTemp.Rows.Count, 1).End(xlUp).Row).Borders(xlInsideHorizontal).LineStyle = xlContinuous
    wsTemp.Range("A5:D" & wsTemp.Cells(wsTemp.Rows.Count, 1).End(xlUp).Row).Borders(xlInsideVertical).LineStyle = xlContinuous
    wsTemp.Cells(1, 1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    wsTemp.DrawingObjects.Visible = True
    wsTemp.DrawingObjects.Delete
    On Error GoTo 0
    wsTemp.Cells(wsTemp.Rows.Count, 1).End(xlUp).Offset(2).Value = "Thanks"
    wsTemp.Range("A1:D1").Merge
    wsTemp.Range("A3:D3").Merge
    wsTemp.Cells.EntireColumn.AutoFit
    wsTemp.Range("A:D").ColumnWidth = 18
    wsTemp.Range("A1:D3").WrapText = True
    wsTemp.Range("A1:D3").Font.Bold = False

    'Publish the sheet to a htm file
    With wbTemp.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=wsTemp.Name, _
         Source:=wsTemp.UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close wbTemp
    wbTemp.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set wbTemp = Nothing
End Function

Public Sub TOGGLEEVENTS(blnState As Boolean)
    Application.DisplayAlerts = blnState
    Application.EnableEvents = blnState
    Application.ScreenUpdating = blnState
    If blnState Then Application.CutCopyMode = False
    If blnState Then Application.StatusBar = False
End Sub

Select allOpen in new window

Also please note that I did set two references here in order to use early binding.  You don't have to have them, but I prefer them.  If this file will move from computer to computer then I would recommend using late binding and we can adjust the code accordingly.  If you try to use the code without setting the proper references then it will fail.  Please look at the top of the code for the commented out code which tells which references to use, there is two of them.

Please let us know if you have any questions.  The code has been tested with the supplied workbook and works for me, getting it as close to your message as possible.

HTH

Regards,
Zack Barresse

I have tested it in the sample and got the same positive result - this is great. I clearly complicated things trying to work with the pivot instead of the raw data.

What happens if I add more data columns - is there a way to define particular ranges?

I'm also curious about line 28 and how it works - Test1 is coded there but how does it run through them all and replace Test1?

I am happy to add the references as needed. Not many people will use the workbook and it will be stored centrally.

Oh darn it, I'm sorry.  That line of code should've been changed.  I hard coded it for testing.  

This line...

If Evaluate("=COUNTIFS('Data'!F:F,""Team1"",'Data'!G:G,""Yes"")") > 0 Then

Select allOpen in new window

... should actually be changed to...

If Evaluate("=COUNTIFS('Data'!F:F," & rCell.Value & ",'Data'!G:G,""Yes"")") > 0 Then

Select allOpen in new window

Very sorry about that, my very large oversight.

We can make the range variable depending on what you want.  I went by your example, so I hid certain columns and filtered what you showed.  If you want other ranges, just let us know how you'd like to show it.  We can do pretty much anything you'd like, so long as you can articulate it to us in detail.  :)

Zack

Hi Zack,

Sorry about the delay -

My working sheet has about 40 columns - is it best to set each unwanted column in line 43?

codevu,

Sorry I haven't been able to respond.  I'll take a look at this tonight.

Zack

Thanks Zack,

No problem, I look forward to your input

Hi Zack,

Thanks for this - I made the changes and have tried this on my own sheet. I appreciate my sheet may be different to the sample but I get an error when running it.

'AutoFilter method of Range class failed' on line 51.

rData.AutoFilter 50, "Yes" - my sheet has a formula which generates "Yes" or "No" based on criteria - is there any reason why I might get an error? Cell formatting? (I've tried general and text)

Any support is much appreciated.

You'll usually see that error with AutoFilter if the Field value isn't set right.  You're setting it at 50.  So if the range started in column A, then 50 would be column AX - and it would need to be included in your range, so it would be A:AX.  In this case, our code for setting the range is this...

Set rData = WS.Range("A1:G" & WS.Cells(WS.Rows.Count, 1).End(xlUp).Row)

Select allOpen in new window

This goes from A1 through column G, the last row being that last row in column A with data found in it.  So it's A1:Gx, where the 'x' is the last (dynamic) row.  You would need to change the G to AX, assuming that's your range.  If your data range didn't start with A, you would need to adjust accordingly.

If you need help with it, just let us know what you're setting the range to and what column you want to filter.  Counting from the left, the first column in your range is going to be 'Field' 1 of the syntax.

Zack